mirror of
https://git.FreeBSD.org/ports.git
synced 2024-12-25 04:43:33 +00:00
604 lines
14 KiB
Plaintext
604 lines
14 KiB
Plaintext
#! %%PERL%% -w
|
||
# ----------------------------------------------------------------------------
|
||
# "THE BEER-WARE LICENSE" (Revision 42)
|
||
# <tobez@FreeBSD.org> wrote this file. As long as you retain this notice you
|
||
# can do whatever you want with this stuff. If we meet some day, and you think
|
||
# this stuff is worth it, you can buy me a beer in return. Anton Berezin
|
||
# ----------------------------------------------------------------------------
|
||
#
|
||
# $FreeBSD$
|
||
# $Id: perl-after-upgrade,v 1.11 2005/06/23 19:39:00 tobez Exp $
|
||
#
|
||
=pod
|
||
|
||
=head1 NAME
|
||
|
||
perl-after-upgrade -- fixup FreeBSD packages that depend on perl
|
||
|
||
=head1 SYNOPSIS
|
||
|
||
perl-after-upgrade
|
||
perl-after-upgrade -f [-d] [-q]
|
||
perl-after-upgrade -v
|
||
|
||
=head1 DESCRIPTION
|
||
|
||
The standard procedure after a perl port (lang/perl5.X) upgrade is to
|
||
basically reinstall all other packages that depend on perl.
|
||
This is always a painful exercise. The perl-after-upgrade utility makes
|
||
this process mostly unnecessary.
|
||
|
||
The tool goes through the list of installed packages, looks for those
|
||
that depend on perl, moves files around, modifies shebang lines in those
|
||
scripts in which it is necessary to do so, tries its best to adjust
|
||
dynamically linked binaries that link with libperl.so in the old path,
|
||
and updates the package database.
|
||
|
||
After installation of the new perl is complete, either by hand from the
|
||
ports collection, or from a package, or via portupgrade, do the
|
||
following:
|
||
|
||
=over 4
|
||
|
||
=item o go root;
|
||
|
||
=item o run perl-after-upgrade utility.
|
||
|
||
Do not specify any arguments at first, so it does nothing destructive.
|
||
Pay attention to the produced output and especially to errorlist at the
|
||
end, if any;
|
||
|
||
=item o run the utility again, with B<-f> command line option.
|
||
|
||
This will actually do the work. Again, pay attention to the output
|
||
produced;
|
||
|
||
=item o fix any reported errors;
|
||
|
||
=item o reinstall required packages:
|
||
|
||
The utility will tell you what packages that depend on perl it could not
|
||
handle. It will also tell you why it happened (for example, they were
|
||
compiled against a binary incompatible perl). If you want such packages
|
||
to remain operational, you will have to reinstall then by hand or via
|
||
portupgrade.
|
||
|
||
=item o review the files left in the older perl installation.
|
||
|
||
This is typically /usr/local/lib/perl5/site_perl/5.X.Y/. There should
|
||
be very little, if any, files in that directory and its subdirectories,
|
||
excepting a number of .ph files;
|
||
|
||
=item o check that things work as they should;
|
||
|
||
=item o remove backup files from the package database.
|
||
|
||
Those will be /var/db/pkg/*/+CONTENTS.bak;
|
||
|
||
=item o that's all.
|
||
|
||
=back
|
||
|
||
=head1 COPYRIGHT AND LICENSE
|
||
|
||
Copyright 2005 by Anton Berezin
|
||
|
||
"THE BEER-WARE LICENSE" (Revision 42)
|
||
<tobez@FreeBSD.org> wrote this module. As long as you retain this
|
||
notice you can do whatever you want with this stuff. If we meet some
|
||
day, and you think this stuff is worth it, you can buy me a beer in
|
||
return.
|
||
|
||
Anton Berezin
|
||
|
||
NO WARRANTY OF ANY KIND, USE AT YOUR OWN RISK.
|
||
|
||
=head1 HISTORY
|
||
|
||
The first version of this utility was not bundled with perl package on
|
||
FreeBSD. It was dumber than the current version in several important
|
||
areas. It was faster.
|
||
|
||
=head1 CREDITS
|
||
|
||
Thanks to Mathieu Arnold for discussion.
|
||
|
||
=head1 SEE ALSO
|
||
|
||
perl(1).
|
||
|
||
=cut
|
||
|
||
use strict;
|
||
use warnings;
|
||
use 5.0100;
|
||
|
||
our $debug = 0;
|
||
|
||
# |/-\
|
||
my $pchar = "|";
|
||
my $do_progress = -t *STDOUT;
|
||
sub progress
|
||
{
|
||
if ($do_progress) {
|
||
print STDERR "$pchar";
|
||
$pchar =~ tr<|/\\-><-|/\\>;
|
||
}
|
||
}
|
||
|
||
package FreeBSD::Package;
|
||
use strict;
|
||
use warnings;
|
||
|
||
use IO::File;
|
||
use File::Copy;
|
||
|
||
sub new
|
||
{
|
||
my ($pkg, %p) = @_;
|
||
my $pkgdir = $p{pkgdir} || return undef;
|
||
my $name = $pkgdir;
|
||
$name =~ s|.*/||;
|
||
main::progress();
|
||
my $c = IO::File->new("< $pkgdir/+CONTENTS");
|
||
return undef unless $c;
|
||
my @lines;
|
||
while (<$c>) {
|
||
chomp;
|
||
push @lines, $_;
|
||
}
|
||
my $me = bless {
|
||
pkgdir => $pkgdir,
|
||
lines => \@lines,
|
||
name => $name,
|
||
}, $pkg;
|
||
return $me;
|
||
}
|
||
|
||
sub name
|
||
{
|
||
return $_[0]->{name};
|
||
}
|
||
|
||
sub lines
|
||
{
|
||
my $me = shift;
|
||
if (@_ && @_ == 1 && ref(@_) eq 'ARRAY') {
|
||
$me->{lines} = [@{$_[0]}];
|
||
$me->{changed} = 1;
|
||
} elsif (@_) {
|
||
$me->{lines} = [@_];
|
||
$me->{changed} = 1;
|
||
} else {
|
||
return @{$me->{lines}};
|
||
}
|
||
}
|
||
|
||
sub write_back
|
||
{
|
||
my ($me) = @_;
|
||
|
||
return unless $me->{changed};
|
||
main::progress();
|
||
my $file = "$me->{pkgdir}/+CONTENTS";
|
||
copy($file, "$file.bak");
|
||
my $c = IO::File->new("> $file");
|
||
return unless $c;
|
||
for (@{$me->{lines}}) {
|
||
print $c "$_\n";
|
||
}
|
||
}
|
||
|
||
package FreeBSD::Package::DB;
|
||
use strict;
|
||
use warnings;
|
||
|
||
sub new
|
||
{
|
||
my ($pkg, %p) = @_;
|
||
my $me = bless {
|
||
dbdir => $p{dbdir} || $ENV{PKG_DBDIR} || "/var/db/pkg",
|
||
}, $pkg;
|
||
$me->{packages} = [ grep { -d } glob "$me->{dbdir}/*" ];
|
||
$me->reset;
|
||
return $me;
|
||
}
|
||
|
||
sub next
|
||
{
|
||
my ($me) = @_;
|
||
while (1) {
|
||
$me->{current}++;
|
||
if ($me->{current} >= @{$me->{packages}}) {
|
||
$me->reset;
|
||
return undef;
|
||
}
|
||
my $pkg = FreeBSD::Package->new(pkgdir => $me->{packages}->[$me->{current}]);
|
||
return $pkg if $pkg;
|
||
}
|
||
}
|
||
|
||
sub reset
|
||
{
|
||
my ($me) = @_;
|
||
$me->{current} = -1;
|
||
}
|
||
|
||
package main;
|
||
use strict;
|
||
use warnings;
|
||
|
||
use File::Temp qw/tempfile/;
|
||
use File::Copy;
|
||
|
||
our $dry_run = 1;
|
||
our $quiet = 0;
|
||
my @tmpl;
|
||
our $VERSION = "1.4";
|
||
|
||
while (@ARGV) {
|
||
my $opt = shift;
|
||
if ($opt eq "-f") {
|
||
$dry_run = 0;
|
||
} elsif ($opt eq "-d") {
|
||
$debug = 1;
|
||
} elsif ($opt eq "-q") {
|
||
$quiet = 1;
|
||
} elsif ($opt eq "-v") {
|
||
$_ = $0;
|
||
s|.*/||;
|
||
print "$_ version $VERSION\n";
|
||
exit 0;
|
||
} elsif ($opt =~ /^-/) {
|
||
$_ = $0;
|
||
s|.*/||;
|
||
print "Unknown option `$opt'\n";
|
||
print "Usage:\n";
|
||
print "\t$_\n\t$_ -v\n\t$_ -f\n";
|
||
exit 1;
|
||
} else {
|
||
push @tmpl, $opt;
|
||
}
|
||
}
|
||
|
||
our $PERL_VERSION = '%%PERL_VERSION%%';
|
||
our $PERL_PKGNAME = '%%PKGNAME%%';
|
||
|
||
our $PERL_VERSION_REGEX = qr/5\.16\.\d+/;
|
||
print STDERR "- Fuzzy source re: <$PERL_VERSION_REGEX>\n" if $debug;
|
||
|
||
our @errors;
|
||
our @notes;
|
||
|
||
sub fix_script
|
||
{
|
||
my ($file) = @_;
|
||
|
||
main::progress();
|
||
return 1 if $dry_run;
|
||
my $sf = IO::File->new("< $file");
|
||
return "" unless $sf;
|
||
my $line = <$sf>;
|
||
my $md5 = "";
|
||
if ($line && $line =~ s|^(\s*#!\s*[\w/]+perl)$PERL_VERSION_REGEX\b|$1$PERL_VERSION|) {
|
||
my $dir = $file;
|
||
$dir =~ s|/[^/]+$||;
|
||
my ($fh, $fn) = tempfile(DIR=> $dir);
|
||
if ($fh) {
|
||
print $fh $line;
|
||
while (<$sf>) {
|
||
print $fh $_;
|
||
}
|
||
close $fh;
|
||
$md5 = `/sbin/md5 -q $fn`;
|
||
chomp $md5;
|
||
my $mode = (stat($file))[2] & 07777;
|
||
unlink $file or do {
|
||
push @errors, "Failed to unlink $file: $!";
|
||
unlink $fn;
|
||
return "";
|
||
};
|
||
rename $fn, $file or do {
|
||
push @errors, "Failed to rename $fn to $file: $!";
|
||
return "";
|
||
};
|
||
chmod $mode, $file;
|
||
} else {
|
||
push @errors, "Failed to modify $file: $!";
|
||
}
|
||
}
|
||
return $md5;
|
||
}
|
||
|
||
sub fix_binary
|
||
{
|
||
my ($file) = @_;
|
||
|
||
main::progress();
|
||
my $sf = IO::File->new("< $file");
|
||
return "" unless $sf;
|
||
my $was = $dry_run ? "would be" : "was";
|
||
push @notes, "The $file binary $was modified, make sure it works";
|
||
return 1 if $dry_run;
|
||
my $md5 = "";
|
||
|
||
my $dir = $file;
|
||
$dir =~ s|/[^/]+$||;
|
||
my ($fh, $fn) = tempfile(DIR=> $dir);
|
||
unless ($fn) {
|
||
push @errors, "Failed to modify $file: $!";
|
||
return "";
|
||
}
|
||
|
||
while (<$sf>) {
|
||
s|/lib/perl5/$PERL_VERSION_REGEX/mach/CORE|/lib/perl5/$PERL_VERSION/mach/CORE|g;
|
||
print $fh $_;
|
||
}
|
||
close $fh;
|
||
$md5 = `/sbin/md5 -q $fn`;
|
||
chomp $md5;
|
||
my $mode = (stat($file))[2] & 07777;
|
||
unlink $file or do {
|
||
push @errors, "Failed to unlink $file: $!";
|
||
unlink $fn;
|
||
return "";
|
||
};
|
||
rename $fn, $file or do {
|
||
push @errors, "Failed to rename $fn to $file: $!";
|
||
return "";
|
||
};
|
||
chmod $mode, $file;
|
||
return $md5;
|
||
}
|
||
|
||
sub mkdir_recur
|
||
{
|
||
my ($dir) = @_;
|
||
|
||
main::progress();
|
||
$dir =~ s|/+$||;
|
||
my $orig = $dir;
|
||
if ($dir =~ m|^$|) {
|
||
return 1;
|
||
} else {
|
||
$dir =~ s|/[^/]+$||;
|
||
my $r = mkdir_recur($dir);
|
||
return $r unless $r;
|
||
mkdir $orig, 0777;
|
||
my $e = $!;
|
||
unless (-d $orig) {
|
||
push @errors, "Could not create directory $orig: $e";
|
||
return 0;
|
||
}
|
||
return 1;
|
||
}
|
||
}
|
||
|
||
sub might_need_to_fix
|
||
{
|
||
my ($pkg) = @_;
|
||
my $pkg_name = $pkg->name;
|
||
|
||
main::progress();
|
||
if ($pkg_name =~ /^bsdpan-/) {
|
||
return 1;
|
||
}
|
||
for ($pkg->lines) {
|
||
if (/^\@pkgdep\s+perl-(threaded-)?($PERL_VERSION_REGEX)\S*\s*$/) {
|
||
return 1;
|
||
}
|
||
}
|
||
return 0;
|
||
}
|
||
|
||
sub fixable_binary
|
||
{
|
||
my ($file, $name) = @_;
|
||
|
||
main::progress();
|
||
my $fixable = 0;
|
||
for (`/usr/bin/ldd $file 2>&1`) {
|
||
if (/^\s+libperl\.so\s+=>/) {
|
||
my $found;
|
||
for (`strings $file`) {
|
||
if (m</lib/perl5/($PERL_VERSION_REGEX)/mach/CORE>) {
|
||
$found++;
|
||
if (length($1) != length($PERL_VERSION)) {
|
||
push @notes, "$name cannot be fixed up (and has to be reinstalled): cannot patch $file due to length difference";
|
||
print STDERR "- Skipping $name: cannot patch $file due to length difference\n" if $debug;
|
||
return undef;
|
||
}
|
||
print STDERR "- $name: fixable binary $file\n" if $debug && $found < 2;
|
||
$fixable = 1 if $1 ne $PERL_VERSION;
|
||
}
|
||
}
|
||
if (!$found) {
|
||
push @notes, "$name cannot be fixed up (and has to be reinstalled): $file is using unknown libperl";
|
||
print STDERR "- Skipping $name: $file is using unknown libperl\n" if $debug;
|
||
return undef;
|
||
}
|
||
}
|
||
}
|
||
return $fixable;
|
||
}
|
||
|
||
sub fixable_shared_lib
|
||
{
|
||
my ($file, $name) = @_;
|
||
|
||
main::progress();
|
||
my ($old);
|
||
for (`strings $file`) {
|
||
if (/^perl_get_sv$/) {
|
||
push @notes, "$name cannot be fixed up (and has to be reinstalled): $file uses an old perl API";
|
||
print STDERR "- Skipping $name: $file uses an old perl API\n" if $debug;
|
||
return 0;
|
||
}
|
||
}
|
||
return 1;
|
||
}
|
||
|
||
sub cannot_be_fixed
|
||
{
|
||
my ($pkg, $binaries, $scripts) = @_;
|
||
my $pkg_name = $pkg->name;
|
||
my $prefix = "";
|
||
|
||
main::progress();
|
||
|
||
for ($pkg->lines) {
|
||
if (/^\@cwd\s+(\S+)\s*$/) {
|
||
$prefix = $1;
|
||
next;
|
||
}
|
||
my $file = "$prefix/$_";
|
||
next if -l $file;
|
||
next if $file =~ /\.gz$/;
|
||
next if $file =~ /\.bz2$/;
|
||
my $sf = IO::File->new("< $file");
|
||
next unless $sf;
|
||
my $line;
|
||
sysread $sf, $line, 256;
|
||
|
||
# binary executable
|
||
if ($line && $line =~ /^\177ELF.\x01.\x09.{8}\x02\0/) {
|
||
my $fixable = fixable_binary($file, $pkg_name);
|
||
return 0 unless defined $fixable;
|
||
push @$binaries, $file if $fixable;
|
||
# shared library - can prevent us from being able to upgrade
|
||
} elsif ($line && $line =~ /^\177ELF.\x01.\x09.{8}\x03\0/) {
|
||
return 0 unless fixable_shared_lib($file, $pkg_name);
|
||
} elsif ($line && $line =~ m<^\s*#!\s*[\w/]+perl($PERL_VERSION_REGEX)\b>) {
|
||
print STDERR "- $pkg_name: fixable script $file\n" if $debug;
|
||
push @$scripts, $file if $1 ne $PERL_VERSION;
|
||
}
|
||
main::progress();
|
||
}
|
||
}
|
||
|
||
#
|
||
my $db = FreeBSD::Package::DB->new;
|
||
my ($fixed, $skipped, $tot_moved, $tot_modified) = (0,0,0,0);
|
||
while (my $pkg = $db->next) {
|
||
my @lines;
|
||
my $new_md5;
|
||
my ($adjusted, $moved, $modified) = (0,0,0);
|
||
|
||
my $pkg_name = $pkg->name;
|
||
if (@tmpl) {
|
||
my $ok;
|
||
for (@tmpl) {
|
||
if ($pkg_name =~ /^$_/) {
|
||
$ok = 1;
|
||
last;
|
||
}
|
||
}
|
||
next unless $ok;
|
||
}
|
||
|
||
unless (might_need_to_fix($pkg)) {
|
||
$skipped++;
|
||
print STDERR "- Skipping $pkg_name, it does not depend on perl\n" if $debug;
|
||
next;
|
||
}
|
||
|
||
my (@binaries_to_fix, @scripts_to_fix);
|
||
if (cannot_be_fixed($pkg, \@binaries_to_fix, \@scripts_to_fix)) {
|
||
$skipped++;
|
||
next;
|
||
}
|
||
if ($debug) {
|
||
print STDERR "- $pkg_name: ", scalar(@binaries_to_fix), " binaries to fix\n" if @binaries_to_fix;
|
||
print STDERR "- $pkg_name: ", scalar(@scripts_to_fix), " scripts to fix\n" if @scripts_to_fix;
|
||
}
|
||
my %binaries = map { $_ => 1 } @binaries_to_fix;
|
||
my %scripts = map { $_ => 1 } @scripts_to_fix;
|
||
|
||
my $prefix = "";
|
||
my $pcnt = 0;
|
||
for ($pkg->lines) {
|
||
if (/^([^@]\S+)\s*$/) {
|
||
my $from = "$prefix/$_";
|
||
local $_; # we'll need it later
|
||
$new_md5 = "";
|
||
unless (-l $from) { # skip symlinks
|
||
if ($binaries{$from}) {
|
||
$new_md5 = fix_binary($from);
|
||
} elsif ($scripts{$from}) {
|
||
$new_md5 = fix_script($from);
|
||
}
|
||
$modified++ if $new_md5;
|
||
}
|
||
my $to = $from;
|
||
if ($to =~ s|(/perl5/(?:site_perl/)?)$PERL_VERSION_REGEX|$1$PERL_VERSION|g) {
|
||
if ($to ne $from) {
|
||
my $dir = $to;
|
||
$dir =~ s|/[^/]+$||;
|
||
main::progress();
|
||
unless ($dry_run) {
|
||
if (mkdir_recur($dir)) {
|
||
move($from, $to);
|
||
} else {
|
||
push @errors, " could not move $from to $to";
|
||
}
|
||
}
|
||
$moved++;
|
||
print STDERR "- move: $from => $to\n" if $debug;
|
||
}
|
||
}
|
||
} elsif (/^\@comment\s+MD5:[\da-f]+\s*$/ && $new_md5) {
|
||
s|MD5:(\S+)|MD5:$new_md5|;
|
||
$new_md5 = "";
|
||
} else {
|
||
$new_md5 = "";
|
||
}
|
||
if (/^\@cwd\s+(\S+)\s*$/) {
|
||
$prefix = $1;
|
||
} elsif (/^\@pkgdep\s+perl-(threaded-)?($PERL_VERSION_REGEX)\S*\s*$/) {
|
||
if ($PERL_VERSION ne $2) {
|
||
my $perlver = $2;
|
||
s|perl-(threaded-)?\Q$perlver\E\S*|$PERL_PKGNAME|;
|
||
}
|
||
}
|
||
my $old = $_;
|
||
if (s|(/perl5/(?:site_perl/)?)$PERL_VERSION_REGEX|$1$PERL_VERSION|g) {
|
||
if ($old ne $_) {
|
||
$adjusted++;
|
||
print STDERR "- adjust: $_\n" if $debug;
|
||
}
|
||
}
|
||
push @lines, $_;
|
||
main::progress() if $pcnt++ % 250 == 0;
|
||
}
|
||
unless ($dry_run) {
|
||
$pkg->lines(@lines);
|
||
$pkg->write_back;
|
||
}
|
||
$fixed++ if $moved || $modified || $adjusted;
|
||
$tot_modified += $modified;
|
||
$tot_moved += $moved;
|
||
say "$pkg_name: $moved moved, $modified modified, $adjusted adjusted"
|
||
if !$quiet || ($moved || $modified || $adjusted);
|
||
}
|
||
print "\n---\n";
|
||
print "Fixed $fixed packages ($tot_moved files moved, $tot_modified files modified)\n";
|
||
print "Skipped $skipped packages\n";
|
||
if (@errors) {
|
||
print "\n**** The script has encountered following problems:\n";
|
||
for (@errors) {
|
||
print "$_\n";
|
||
}
|
||
print "\n--- Repeating summary:\n";
|
||
print "Fixed $fixed packages ($tot_moved files moved, $tot_modified files modified)\n";
|
||
print "Skipped $skipped packages\n";
|
||
}
|
||
if (@notes) {
|
||
print "\n**** In addition, please pay attention to the following:\n";
|
||
for (@notes) {
|
||
print "$_\n";
|
||
}
|
||
print "\n--- Repeating summary:\n";
|
||
print "Fixed $fixed packages ($tot_moved files moved, $tot_modified files modified)\n";
|
||
print "Skipped $skipped packages\n";
|
||
}
|