This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
New file. Part of MakeMaker 5.21.
[perl5.git] / lib / ExtUtils / Install.pm
CommitLineData
4b6d56d3
PP
1package ExtUtils::Install;
2
3require Exporter;
4@ISA = ('Exporter');
5@EXPORT = ('install','uninstall');
6
7use Carp;
8use Cwd qw(cwd);
9use ExtUtils::MakeMaker; # to implement a MY class
10use File::Basename qw(dirname);
11use File::Copy qw(copy);
12use File::Find qw(find);
13use File::Path qw(mkpath);
14#use strict;
15
16sub 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
137sub 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
1511;
152
153__END__
154
155=head1 NAME
156
157ExtUtils::Install - install files from here to there
158
159=head1 SYNOPSIS
160
161B<use ExtUtils::Install;>
162
163B<install($hashref,$verbose,$nonono);>
164
165B<uninstall($packlistfile,$verbose,$nonono);>
166
167=head1 DESCRIPTION
168
169Both functions, install() and uninstall() are specific to the way
170ExtUtils::MakeMaker handles the installation and deinstallation of
171perl modules. They are not designed as general purpose tools.
172
173install() takes three arguments. A reference to a hash, a verbose
174switch and a don't-really-do-it switch. The hash ref contains a
175mapping of directories: each key/value pair is a combination of
176directories to be copied. Key is a directory to copy from, value is a
177directory to copy to. The whole tree below the "from" directory will
178be copied preserving timestamps and permissions.
179
180There 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
182target files to the file named by $hashref->{write}. If there is
183another file named by $hashref->{read}, the contents of this file will
184be merged into the written file. The read and the written file may be
185identical, but on AFS it is quite likely, people are installing to a
186different directory than the one where the files later appear.
187
188uninstall() takes as first argument a file containing filenames to be
189unlinked. The second argument is a verbose switch, the third is a
190no-don't-really-do-it-now switch.
191
192=cut
193
194#=head1 NOTES
195
196#=head1 BUGS
197
198#=head1 AUTHORS
199