lib/ExtUtils/Install.pm

   1 package ExtUtils::Install;
   2
   3 require Exporter;
   4 @ISA = ('Exporter');
   5 @EXPORT = ('install','uninstall');
   6
   7 use Carp;
   8 use Cwd qw(cwd);
   9 use ExtUtils::MakeMaker; # to implement a MY class
  10 use File::Basename qw(dirname);
  11 use File::Copy qw(copy);
  12 use File::Find qw(find);
  13 use File::Path qw(mkpath);
  14 #use strict;
  15
  16 sub install {
  17     my($hash,$verbose,$nonono) = @_;
  18     $verbose ||= 0;
  19     $nonono  ||= 0;
  20     my(%hash) = %$hash;
  21     my(%pack, %write,$dir);
  22     local(*DIR, *P);
  23     for (qw/read write/) {
  24         $pack{$_}=$hash{$_};
  25         delete $hash{$_};
  26     }
  27     my($blibdir);
  28     foreach $blibdir (sort keys %hash) {
  29         #Check if there are files, and if yes, look if the corresponding
  30         #target directory is writable for us
  31         opendir DIR, $blibdir or next;
  32         while ($_ = readdir DIR) {
  33             next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
  34             if (-w $hash{$blibdir} || mkpath($hash{$blibdir})) {
  35                 last;
  36             } else {
  37                 croak("You do not have permissions to install into $hash{$blibdir}");
  38             }
  39         }
  40         closedir DIR;
  41     }
  42     if (-f $pack{"read"}) {
  43         open P, $pack{"read"} or die "Couldn't read $pack{'read'}";
  44         # Remember what you found
  45         while (<P>) {
  46             chomp;
  47             $write{$_}++;
  48         }
  49         close P;
  50     }
  51     my $cwd = cwd();
  52     my $umask = umask 0;
  53
  54     # This silly reference is just here to be able to call MY->catdir
  55     # without a warning (Waiting for a proper path/directory module,
  56     # Charles!) The catdir and catfile calls leave us with a lot of
  57     # paths containing ././, but I don't want to use regexes on paths
  58     # anymore to delete them :-)
  59     my $MY = {};
  60     bless $MY, 'MY';
  61     my($source);
  62     MOD_INSTALL: foreach $source (sort keys %hash) {
  63         #copy the tree to the target directory without altering
  64         #timestamp and permission and remember for the .packlist
  65         #file. The packlist file contains the absolute paths of the
  66         #install locations. AFS users may call this a bug. We'll have
  67         #to reconsider how to add the means to satisfy AFS users also.
  68         chdir($source) or next;
  69         find(sub {
  70             my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  71                          $atime,$mtime,$ctime,$blksize,$blocks) = stat;
  72             return unless -f _;
  73             return if $_ eq ".exists";
  74             my $targetdir = $MY->catdir($hash{$source},$File::Find::dir);
  75             my $targetfile = $MY->catfile($targetdir,$_);
  76             my $diff = 0;
  77
  78             if ( -f $targetfile && -s _ == $size) {
  79                 # We have a good chance, we can skip this one
  80                 local(*F,*T);
  81                 open F, $_ or croak("Couldn't open $_: $!");
  82                 open T, $targetfile or croak("Couldn't open $targetfile: $!");
  83                 my($fr, $tr, $fbuf,$tbuf,$size);
  84                 $size = 1024;
  85                 # print "Reading $_\n";
  86                 while ( $fr = read(F,$fbuf,$size)) {
  87                     unless (
  88                             $tr = read(T,$tbuf,$size) and
  89                             $tbuf eq $fbuf
  90                            ){
  91                         # print "diff ";
  92                         $diff++;
  93                         last;
  94                     }
  95                     # print "$fr/$tr ";
  96                 }
  97                 # print "\n";
  98                 close F;
  99                 close T;
 100             } else {
 101                 print "$_ differs\n" if $verbose>1;
 102                 $diff++;
 103             }
 104
 105             if ($diff){
 106                 mkpath($targetdir,0,0755) unless $nonono;
 107                 print "mkpath($targetdir,0,0755)\n" if $verbose>1;
 108                 unlink $targetfile if -f $targetfile;
 109                 copy($_,$targetfile) unless $nonono;
 110                 print "Installing $targetfile\n" if $verbose;
 111                 utime($atime,$mtime,$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 croak("Couldn't chdir....");
 123     }
 124     umask $umask;
 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 croak("Couldn't write $pack{'write'}: $!");
 130         for (sort keys %write) {
 131             print P "$_\n";
 132         }
 133         close P;
 134     }
 135 }
 136
 137 sub uninstall {
 138     my($fil,$verbose,$nonono) = @_;
 139     die "no packlist file found: $fil" unless -f $fil;
 140     local *P;
 141     open P, $fil or croak("uninstall: Could not read packlist file $fil: $!");
 142     while (<P>) {
 143         chomp;
 144         print "unlink $_\n" if $verbose;
 145         unlink($_) || carp("Couldn't unlink $_") unless $nonono;
 146     }
 147     print "unlink $fil\n" if $verbose;
 148     unlink($fil) || carp("Couldn't unlink $fil") unless $nonono;
 149 }
 150
 151 1;
 152
 153 __END__
 154
 155 =head1 NAME
 156
 157 ExtUtils::Install - install files from here to there
 158
 159 =head1 SYNOPSIS
 160
 161 B<use ExtUtils::Install;>
 162
 163 B<install($hashref,$verbose,$nonono);>
 164
 165 B<uninstall($packlistfile,$verbose,$nonono);>
 166
 167 =head1 DESCRIPTION
 168
 169 Both functions, install() and uninstall() are specific to the way
 170 ExtUtils::MakeMaker handles the installation and deinstallation of
 171 perl modules. They are not designed as general purpose tools.
 172
 173 install() takes three arguments. A reference to a hash, a verbose
 174 switch and a don't-really-do-it switch. The hash ref contains a
 175 mapping of directories: each key/value pair is a combination of
 176 directories to be copied. Key is a directory to copy from, value is a
 177 directory to copy to. The whole tree below the "from" directory will
 178 be copied preserving timestamps and permissions.
 179
 180 There are two keys with a special meaning in the hash: "read" and
 181 "write". After the copying is done, install will write the list of
 182 target files to the file named by $hashref->{write}. If there is
 183 another file named by $hashref->{read}, the contents of this file will
 184 be merged into the written file. The read and the written file may be
 185 identical, but on AFS it is quite likely, people are installing to a
 186 different directory than the one where the files later appear.
 187
 188 uninstall() takes as first argument a file containing filenames to be
 189 unlinked. The second argument is a verbose switch, the third is a
 190 no-don't-really-do-it-now switch.
 191
 192 =cut
 193
 194 #=head1 NOTES
 195
 196 #=head1 BUGS
 197
 198 #=head1 AUTHORS
 199