lib/ExtUtils/Install.pm

   1 package ExtUtils::Install;
   2
   3 use Exporter;
   4 use SelfLoader;
   5 use Carp ();
   6
   7 @ISA = ('Exporter');
   8 @EXPORT = ('install','uninstall','pm_to_blib');
   9 $Is_VMS = $^O eq 'VMS';
  10
  11 #use vars qw( @EXPORT @ISA $Is_VMS );
  12 #use strict;
  13
  14 1;
  15
  16 sub ExtUtils::Install::install;
  17 sub ExtUtils::Install::uninstall;
  18 sub ExtUtils::Install::pm_to_blib;
  19 sub ExtUtils::Install::my_cmp;
  20
  21 __DATA__
  22
  23 sub install {
  24     my($hash,$verbose,$nonono) = @_;
  25     $verbose ||= 0;
  26     $nonono  ||= 0;
  27
  28     use Cwd qw(cwd);
  29     use ExtUtils::MakeMaker; # to implement a MY class
  30     use File::Basename qw(dirname);
  31     use File::Copy qw(copy);
  32     use File::Find qw(find);
  33     use File::Path qw(mkpath);
  34     # require "auto/ExtUtils/Install/my_cmp.al"; # Hairy, but for the first
  35     # time use we are in a different directory when autoload happens, so
  36     # the relativ path to ./blib is ill.
  37
  38     my(%hash) = %$hash;
  39     my(%pack, %write, $dir);
  40     local(*DIR, *P);
  41     for (qw/read write/) {
  42         $pack{$_}=$hash{$_};
  43         delete $hash{$_};
  44     }
  45     my($source_dir_or_file);
  46     foreach $source_dir_or_file (sort keys %hash) {
  47         #Check if there are files, and if yes, look if the corresponding
  48         #target directory is writable for us
  49         opendir DIR, $source_dir_or_file or next;
  50         while ($_ = readdir DIR) {
  51             next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
  52             if (-w $hash{$source_dir_or_file} || mkpath($hash{$source_dir_or_file})) {
  53                 last;
  54             } else {
  55                 Carp::croak("You do not have permissions to install into $hash{$source_dir_or_file}");
  56             }
  57         }
  58         closedir DIR;
  59     }
  60     if (-f $pack{"read"}) {
  61         open P, $pack{"read"} or Carp::croak("Couldn't read $pack{'read'}");
  62         # Remember what you found
  63         while (<P>) {
  64             chomp;
  65             $write{$_}++;
  66         }
  67         close P;
  68     }
  69     my $cwd = cwd();
  70     my $umask = umask 0 unless $Is_VMS;
  71
  72     # This silly reference is just here to be able to call MY->catdir
  73     # without a warning (Waiting for a proper path/directory module,
  74     # Charles!)
  75     my $MY = {};
  76     bless $MY, 'MY';
  77     my($source);
  78     MOD_INSTALL: foreach $source (sort keys %hash) {
  79         #copy the tree to the target directory without altering
  80         #timestamp and permission and remember for the .packlist
  81         #file. The packlist file contains the absolute paths of the
  82         #install locations. AFS users may call this a bug. We'll have
  83         #to reconsider how to add the means to satisfy AFS users also.
  84         chdir($source) or next;
  85         find(sub {
  86             my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  87                          $atime,$mtime,$ctime,$blksize,$blocks) = stat;
  88             return unless -f _;
  89             return if $_ eq ".exists";
  90             my $targetdir = $MY->catdir($hash{$source},$File::Find::dir);
  91             my $targetfile = $MY->catfile($targetdir,$_);
  92             my $diff = 0;
  93
  94             if ( -f $targetfile && -s _ == $size) {
  95                 # We have a good chance, we can skip this one
  96                 $diff = my_cmp($_,$targetfile);
  97             } else {
  98                 print "$_ differs\n" if $verbose>1;
  99                 $diff++;
 100             }
 101
 102             if ($diff){
 103                 if (-f $targetfile){
 104                     unlink $targetfile or Carp::croak("Couldn't unlink $targetfile");
 105                 } else {
 106                     mkpath($targetdir,0,0755) unless $nonono;
 107                     print "mkpath($targetdir,0,0755)\n" if $verbose>1;
 108                 }
 109                 copy($_,$targetfile) unless $nonono;
 110                 print "Installing $targetfile\n" if $verbose;
 111                 utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
 112                 print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
 113                 chmod $mode, $targetfile;
 114                 print "chmod($mode, $targetfile)\n" if $verbose>1;
 115             } else {
 116                 print "Skipping $targetfile (unchanged)\n";
 117             }
 118
 119             $write{$targetfile}++;
 120
 121         }, ".");
 122         chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
 123     }
 124     umask $umask unless $Is_VMS;
 125     if ($pack{'write'}) {
 126         $dir = dirname($pack{'write'});
 127         mkpath($dir,0,0755);
 128         print "Writing $pack{'write'}\n";
 129         open P, ">$pack{'write'}" or Carp::croak("Couldn't write $pack{'write'}: $!");
 130         for (sort keys %write) {
 131             print P "$_\n";
 132         }
 133         close P;
 134     }
 135 }
 136
 137 sub my_cmp {
 138     my($one,$two) = @_;
 139     local(*F,*T);
 140     my $diff = 0;
 141     open T, $two or return 1;
 142     open F, $one or Carp::croak("Couldn't open $one: $!");
 143     my($fr, $tr, $fbuf, $tbuf, $size);
 144     $size = 1024;
 145     # print "Reading $one\n";
 146     while ( $fr = read(F,$fbuf,$size)) {
 147         unless (
 148                 $tr = read(T,$tbuf,$size) and
 149                 $tbuf eq $fbuf
 150                ){
 151             # print "diff ";
 152             $diff++;
 153             last;
 154         }
 155         # print "$fr/$tr ";
 156     }
 157     # print "\n";
 158     close F;
 159     close T;
 160     $diff;
 161 }
 162
 163 sub uninstall {
 164     my($fil,$verbose,$nonono) = @_;
 165     die "no packlist file found: $fil" unless -f $fil;
 166     local *P;
 167     open P, $fil or Carp::croak("uninstall: Could not read packlist file $fil: $!");
 168     while (<P>) {
 169         chomp;
 170         print "unlink $_\n" if $verbose;
 171         unlink($_) || Carp::carp("Couldn't unlink $_") unless $nonono;
 172     }
 173     print "unlink $fil\n" if $verbose;
 174     unlink($fil) || Carp::carp("Couldn't unlink $fil") unless $nonono;
 175 }
 176
 177 sub pm_to_blib {
 178     my($fromto,$autodir) = @_;
 179
 180     use File::Basename qw(dirname);
 181     use File::Copy qw(copy);
 182     use File::Path qw(mkpath);
 183     use AutoSplit;
 184
 185     my $umask = umask 0022 unless $Is_VMS;
 186     mkpath($autodir,0,0755);
 187     foreach (keys %$fromto) {
 188         next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
 189         unless (my_cmp($_,$fromto->{$_})){
 190             print "Skip $fromto->{$_} (unchanged)\n";
 191             next;
 192         }
 193         if (-f $fromto->{$_}){
 194             unlink $fromto->{$_} or Carp::carp("Couldn't unlink $fromto->{$_}");
 195         } else {
 196             mkpath(dirname($fromto->{$_}),0,0755);
 197         }
 198         copy($_,$fromto->{$_});
 199         chmod((stat)[2],$fromto->{$_});
 200         print "cp $_ $fromto->{$_}\n";
 201         next unless /\.pm$/;
 202         autosplit($fromto->{$_},$autodir);
 203     }
 204     umask $umask unless $Is_VMS;
 205 }
 206
 207 1;
 208
 209 __END__
 210
 211 =head1 NAME
 212
 213 ExtUtils::Install - install files from here to there
 214
 215 =head1 SYNOPSIS
 216
 217 B<use ExtUtils::Install;>
 218
 219 B<install($hashref,$verbose,$nonono);>
 220
 221 B<uninstall($packlistfile,$verbose,$nonono);>
 222
 223 B<pm_to_blib($hashref);>
 224
 225 =head1 DESCRIPTION
 226
 227 Both install() and uninstall() are specific to the way
 228 ExtUtils::MakeMaker handles the installation and deinstallation of
 229 perl modules. They are not designed as general purpose tools.
 230
 231 install() takes three arguments. A reference to a hash, a verbose
 232 switch and a don't-really-do-it switch. The hash ref contains a
 233 mapping of directories: each key/value pair is a combination of
 234 directories to be copied. Key is a directory to copy from, value is a
 235 directory to copy to. The whole tree below the "from" directory will
 236 be copied preserving timestamps and permissions.
 237
 238 There are two keys with a special meaning in the hash: "read" and
 239 "write". After the copying is done, install will write the list of
 240 target files to the file named by $hashref->{write}. If there is
 241 another file named by $hashref->{read}, the contents of this file will
 242 be merged into the written file. The read and the written file may be
 243 identical, but on AFS it is quite likely, people are installing to a
 244 different directory than the one where the files later appear.
 245
 246 uninstall() takes as first argument a file containing filenames to be
 247 unlinked. The second argument is a verbose switch, the third is a
 248 no-don't-really-do-it-now switch.
 249
 250 pm_to_blib() takes a hashref as the first argument and copies all keys
 251 of the hash to the corresponding values efficiently. Filenames with
 252 the extension pm are autosplit. Second argument is the autosplit
 253 directory.
 254
 255 =cut
 256