home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _8774747bb3bdf316aafd6c2b71b83952 < prev    next >
Encoding:
Text File  |  2004-06-01  |  8.0 KB  |  303 lines
  1. package ActiveState::RelocateTree;
  2. require Exporter;
  3.  
  4. use strict;
  5. use Config;
  6. use Cwd qw(abs_path getcwd);
  7. use File::Basename qw(dirname basename);
  8. use File::Copy ();
  9. use File::Find;
  10. use File::Path;
  11. use File::Spec;
  12.  
  13. use vars qw(@ISA @EXPORT_OK $VERSION);
  14. @ISA = qw(Exporter);
  15. @EXPORT_OK = qw(relocate edit check move_tree spongedir rel2abs abs2rel);
  16. $VERSION = '0.03';
  17.  
  18. my $modifier = $^O eq 'MSWin32' ? '(?i)' : '';
  19.  
  20. # This variable has to be built up, or this package itself will be relocated.
  21. # That should never happen, since the unmodified path is needed by PPM.
  22. # Scripts like reloc_perl provide their own default, which will of course get
  23. # relocated as wanted.
  24. sub spongedir {
  25.     my %sponges = (
  26.     ppm => '/tmp'.'/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl',
  27.     thisperl => 'C:\p4view\Apps\Gecko\build\build-2004'.'0601T114421-qjjgghwhfp\ActivePerl\Perl',
  28.     );
  29.     return $sponges{lc$_[0]};
  30. }
  31.  
  32. sub relocate {
  33.     my %opt = (
  34. #    to       => ??? -> you have to provide this one
  35.     from     => $Config{prefix},
  36.  
  37.     quiet    => 0,
  38.     verbose  => 0,
  39.     filelist => undef,
  40.  
  41.     ranlib   => 1,
  42.     textonly => 0,
  43.  
  44.     savebaks => 0,
  45.     bak      => '.~1~',
  46.  
  47.     inplace  => 0,
  48.     killorig => 0,
  49.     usenlink => 1,
  50.     @_,
  51.     );
  52.     $opt{search}  = $opt{from} unless exists $opt{search};
  53.     $opt{replace} = $opt{to}   unless exists $opt{replace};
  54.     $opt{inplace} = 1          if $opt{to} eq $opt{from};
  55.  
  56.     local *STDOUT if $opt{quiet};
  57.     unless ($opt{to}) {
  58.     warn "No `to' path given to relocate(): cannot continue";
  59.     return;
  60.     }
  61.  
  62.     # Substitute '/' or '\\' characters with [/\\] if this is Windows. This
  63.     # allows matching either slashes or backslashes.
  64.     my $regexp;
  65.     if ($^O eq 'MSWin32') {
  66.     my @parts = map { quotemeta } split m#[/\\]#, $opt{search};
  67.     $regexp = join '[/\\\\]', @parts;
  68.     }
  69.     else {
  70.     $regexp = quotemeta($opt{search});
  71.     }
  72.  
  73.     move_tree(@opt{qw(from to killorig verbose usenlink)})
  74.     unless $opt{inplace};
  75.  
  76.     my (@bin, @text);
  77.     {
  78.     # On HP-UX with pfs_mount, nlink is always 2.
  79.     local $File::Find::dont_use_nlink = !$opt{usenlink};
  80.     find(sub {
  81.         return if -l;
  82.         return unless -f && -s;
  83.         if (-B) {
  84.         return if $opt{textonly};
  85.         push @bin, $File::Find::name if check($_, $regexp, 1);
  86.         }
  87.         else {
  88.         push @text, $File::Find::name if check($_, $regexp, 0)
  89.         }
  90.     }, resolve($opt{to}));
  91.     }
  92.  
  93.     # show affected files
  94.     print "Configuring Perl installation at $opt{to}\n"
  95.     if @bin or @text;
  96.  
  97.     if ($opt{filelist}) {
  98.     open LOG, "> $opt{filelist}" or die "can't open $opt{filelist}: $!";
  99.     print LOG "$_\n" for (@bin, @text);
  100.     close LOG or die "can't close $opt{filelist}: $!";
  101.     }
  102.     if ($opt{verbose}) {
  103.     print "Translating $opt{search} to $opt{replace}\n";
  104.     print "editing $_\n" for (@bin, @text);
  105.     }
  106.  
  107.     # edit files
  108.     edit($regexp, @opt{qw(search replace bak)}, 0, @text);
  109.     edit($regexp, @opt{qw(search replace bak)}, 1, @bin);
  110.  
  111.     # clobber backups
  112.     unless ($opt{savebaks}) {
  113.     print "cleaning out backups\n" if $opt{verbose};
  114.     unlink "$_$opt{bak}" for (@text, @bin);
  115.     }
  116.  
  117.     # run ranlib, where appropriate
  118.     my $rl = $Config{ranlib};
  119.     $rl = '' if $rl =~ /^:?\s*$/;
  120.     if ($rl and $opt{ranlib}) {
  121.     for (@bin) {
  122.         if (/\Q$Config{_a}\E$/o) {
  123.         print "$rl $_\n" if $opt{verbose};
  124.         system("$rl $_") == 0 or die "`$rl $_' failed: $?";
  125.         }
  126.     }
  127.     }
  128. }
  129.  
  130. sub check {
  131.     my $file = shift;
  132.     my $re   = shift;
  133.     my $bin  = shift;
  134.     local (*F, $_);
  135.     open F, "< $file" or die "Can't open `$file': $!";
  136.     binmode F if $bin;
  137.     my $mod = $modifier;
  138.     while (<F>) {
  139.     return 1 if /$mod$re/;
  140.     }
  141.     return 0;
  142. }
  143.  
  144. sub edit {
  145.     my $re   = shift;
  146.     my $from = shift;
  147.     my $dest = shift;
  148.     my $bak  = shift;
  149.     my $bin  = shift;
  150.     return unless @_; # prevent reading from STDIN
  151.  
  152.     my $mod  = $modifier;
  153.     my $term = $bin ? '([^\0]*\0)' : '()';
  154.     my $pad  = $bin ? "\0" x (length($from) - length($dest)) : '';
  155.  
  156.     local ($_, *INPUT, *OUTPUT);
  157.     my $old = select(STDOUT);
  158.     for my $file (@_) {
  159.     rename($file, "$file$bak")
  160.         or do { warn "can't rename $file: $!" if $^W; next };
  161.     open(INPUT,   "< $file$bak")
  162.         or do { warn "can't open $file$bak: $!" if $^W; next };
  163.     open(OUTPUT,  "> $file")
  164.         or do { warn "can't write $file: $!" if $^W; next };
  165.     chmod((stat "$file$bak")[2] & 07777, $file);
  166.     binmode(INPUT), binmode(OUTPUT) if $bin;
  167.     select(OUTPUT);
  168.     if ($^O eq 'MSWin32') {
  169.         while (<INPUT>) {
  170.             if (m[($mod$re$term)]) {
  171.             # if the string to be modified has backslashes anywhere
  172.             # in it and has no forward slashes, make the replacement
  173.             # string backslashed too
  174.             my $match = $1;
  175.             my $d = $dest;
  176.             if ($match =~ m[\\] and $match !~ m[/]) {
  177.                 $d =~ s[/][\\]g;
  178.             }
  179.             s[$mod$re$term][$d$1$pad]g;
  180.         }
  181.         print;
  182.         }
  183.     }
  184.     else {
  185.         while (<INPUT>) {
  186.         s[$mod$re$term][$dest$1$pad]g;
  187.         print;
  188.         }
  189.     }
  190.     close(OUTPUT);
  191.     close(INPUT);
  192.     }
  193.     select($old);
  194.  
  195. # Unfortunately, this doesn't work in 5.005_03. Oh, how I wish it would just
  196. # die once and for all!
  197. #    local ($_, *ARGV, *ARGVOUT);
  198. #    local $^I = $bak;
  199. #    @ARGV = @_;
  200. #    binmode(ARGV), binmode(ARGVOUT) if $bin;
  201. #    while (<>) {
  202. #    s[$mod\Q$from\E$term][$dest$1$pad]g;
  203. #    print;
  204. #    close ARGV if eof;
  205. #    }
  206. }
  207.  
  208. sub move_tree {
  209.     my ($from, $to, $kill, $verbose, $usenlink) = @_;
  210.     $from = rel2abs(resolve($from));
  211.     $to   = rel2abs($to);
  212.     # On HP-UX with pfs_mount, nlink is always 2.
  213.     local $File::Find::dont_use_nlink = !$usenlink;
  214.     find(sub {
  215.     my $src = abs2rel($File::Find::name, $from);
  216.     if (-l) {
  217.         # Resolve the source link. If it points inside the source tree,
  218.         # build a similar one which points to the same relative location
  219.         # in the destination tree. Else, copy it if it points to a file,
  220.         # else *ignore it*.
  221.         my $resolved = resolve($_);
  222.         if ($resolved =~ /^$modifier\Q$from\E/) {
  223.         my $rel = abs2rel($resolved, $from);
  224.         my $dest = File::Spec->catfile($to, $rel);
  225.         my $link = File::Spec->catfile($to, $src);
  226.         symlink($dest, $link)
  227.             || die "Can't create symlink at '$link': $!";
  228.         return;
  229.         }
  230.     }
  231.     if (-f) {
  232.         my $file = File::Spec->catfile($to, $src);
  233.         File::Copy::syscopy($File::Find::name, $file)
  234.         || die "Can't copy to '$file': $!";
  235.         my $srcmode = (stat $File::Find::name)[2];
  236.         chmod($srcmode & 07777, $file);
  237.     }
  238.     elsif (-d) {
  239.         my $dir = File::Spec->catdir($to, $src);
  240.         mkpath($dir, 0, 0755); # don't bother preserving directory mode
  241.     }
  242.     else {
  243.         # silently ignore
  244.     }
  245.     }, $from);
  246.     if ($kill) {
  247.     print "deleting $from\n" if $verbose;
  248.     rmtree($from, 0, 0);
  249.     }
  250. }
  251.  
  252. {
  253.     my $rel2abs_test = eval { File::Spec->rel2abs('.'); 1 };
  254.     my $abs2rel_test = eval { File::Spec->abs2rel('.', '.'); $^O ne 'MSWin32' };
  255.     my $symlink_test = eval { symlink('', ''); 1 };
  256.  
  257.     sub resolve {
  258.     my $l = shift;
  259.     return $l unless $symlink_test;
  260.     return $l unless -l $l;
  261.     my $d = dirname($l);
  262.     my $v = readlink($l);
  263.     return rel2abs($v, $d);
  264.     }
  265.  
  266.     sub rel2abs {
  267.     my ($rel, $relto) = @_;
  268.     my ($base, $rest);
  269.     if ($rel2abs_test) {
  270.         $base = File::Spec->rel2abs(@_);
  271.         $rest = '';
  272.     }
  273.     else {
  274.         # Support for 5.005:
  275.         return $rel if File::Spec->file_name_is_absolute($rel);
  276.         if    (!defined $relto) { $relto = getcwd(); }
  277.         elsif (!File::Spec->file_name_is_absolute($relto)) {
  278.         $relto = rel2abs($relto);
  279.         }
  280.         ($base, $rest) = (File::Spec->catdir($relto, $rel), '');
  281.     }
  282.     until (-d $base) {
  283.         $rest = File::Spec->catdir(basename($base), $rest);
  284.         $base = dirname($base);
  285.     }
  286.     return File::Spec->catdir(abs_path($base), $rest) if $base and $rest;
  287.     return abs_path($base) if $base and not $rest;
  288.     die "can't absolutize $rel against $relto\n";
  289.     }
  290.  
  291.     sub abs2rel {
  292.     return File::Spec->abs2rel(@_) if $abs2rel_test;
  293.  
  294.     # Support for 5.005:
  295.     my $abs  = shift;
  296.     my $from = shift;
  297.     (my $rel  = $abs) =~ s#$modifier^\Q$from\E[\\/]?##;
  298.     return $rel;
  299.     }
  300. }
  301.  
  302. 1;
  303.