Commit | Line | Data |
fe3b3201 |
1 | #line 1 |
0d5e38d1 |
2 | # $File: //member/autrijus/ExtUtils-AutoInstall/lib/ExtUtils/AutoInstall.pm $ |
3 | # $Revision: #9 $ $Change: 9532 $ $DateTime: 2004/01/01 06:47:30 $ vim: expandtab shiftwidth=4 |
4 | |
5 | package ExtUtils::AutoInstall; |
6 | $ExtUtils::AutoInstall::VERSION = '0.56'; |
7 | |
8 | use strict; |
9 | use Cwd (); |
10 | use ExtUtils::MakeMaker (); |
11 | |
ecac864a |
12 | #line 281 |
0d5e38d1 |
13 | |
14 | # special map on pre-defined feature sets |
15 | my %FeatureMap = ( |
16 | '' => 'Core Features', # XXX: deprecated |
17 | '-core' => 'Core Features', |
18 | ); |
19 | |
20 | # various lexical flags |
21 | my (@Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS); |
22 | my ($Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly); |
23 | my ($PostambleActions, $PostambleUsed); |
24 | |
25 | $AcceptDefault = 1 unless -t STDIN; # non-interactive session |
26 | _init(); |
27 | |
28 | sub missing_modules { |
29 | return @Missing; |
30 | } |
31 | |
32 | sub do_install { |
33 | __PACKAGE__->install( |
34 | [ UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config}], |
35 | @Missing, |
36 | ); |
37 | } |
38 | |
39 | # initialize various flags, and/or perform install |
40 | sub _init { |
41 | foreach my $arg (@ARGV, split(/[\s\t]+/, $ENV{PERL_EXTUTILS_AUTOINSTALL} || '')) { |
42 | if ($arg =~ /^--config=(.*)$/) { |
43 | $Config = [ split(',', $1) ]; |
44 | } |
45 | elsif ($arg =~ /^--installdeps=(.*)$/) { |
46 | __PACKAGE__->install($Config, @Missing = split(/,/, $1)); |
47 | exit 0; |
48 | } |
49 | elsif ($arg =~ /^--default(?:deps)?$/) { |
50 | $AcceptDefault = 1; |
51 | } |
52 | elsif ($arg =~ /^--check(?:deps)?$/) { |
53 | $CheckOnly = 1; |
54 | } |
55 | elsif ($arg =~ /^--skip(?:deps)?$/) { |
56 | $SkipInstall = 1; |
57 | } |
58 | elsif ($arg =~ /^--test(?:only)?$/) { |
59 | $TestOnly = 1; |
60 | } |
61 | } |
62 | } |
63 | |
64 | # overrides MakeMaker's prompt() to automatically accept the default choice |
65 | sub _prompt { |
66 | goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; |
67 | |
68 | my ($prompt, $default) = @_; |
69 | my $y = ($default =~ /^[Yy]/); |
70 | |
71 | print $prompt, ' [', ($y ? 'Y' : 'y'), '/', ($y ? 'n' : 'N'), '] '; |
72 | print "$default\n"; |
73 | return $default; |
74 | } |
75 | |
76 | # the workhorse |
77 | sub import { |
78 | my $class = shift; |
79 | my @args = @_ or return; |
80 | my $core_all; |
81 | |
82 | print "*** $class version ".$class->VERSION."\n"; |
83 | print "*** Checking for dependencies...\n"; |
84 | |
85 | my $cwd = Cwd::cwd(); |
86 | |
87 | $Config = []; |
88 | |
89 | my $maxlen = length((sort { length($b) <=> length($a) } |
90 | grep { /^[^\-]/ } |
91 | map { ref($_) ? keys %{ref($_) eq 'HASH' ? $_ : +{@{$_}}} : '' } |
92 | map { +{@args}->{$_} } |
93 | grep { /^[^\-]/ or /^-core$/i } keys %{+{@args}})[0]); |
94 | |
95 | while (my ($feature, $modules) = splice(@args, 0, 2)) { |
96 | my (@required, @tests, @skiptests); |
97 | my $default = 1; |
98 | my $conflict = 0; |
99 | |
100 | if ($feature =~ m/^-(\w+)$/) { |
101 | my $option = lc($1); |
102 | |
103 | # check for a newer version of myself |
104 | _update_to($modules, @_) and return if $option eq 'version'; |
105 | |
106 | # sets CPAN configuration options |
107 | $Config = $modules if $option eq 'config'; |
108 | |
109 | # promote every features to core status |
110 | $core_all = ($modules =~ /^all$/i) and next |
111 | if $option eq 'core'; |
112 | |
113 | next unless $option eq 'core'; |
114 | } |
115 | |
116 | print "[".($FeatureMap{lc($feature)} || $feature)."]\n"; |
117 | |
118 | $modules = [ %{$modules} ] if UNIVERSAL::isa($modules, 'HASH'); |
119 | |
120 | unshift @$modules, -default => &{shift(@$modules)} |
121 | if (ref($modules->[0]) eq 'CODE'); # XXX: bugward combatability |
122 | |
123 | while (my ($mod, $arg) = splice(@$modules, 0, 2)) { |
124 | if ($mod =~ m/^-(\w+)$/) { |
125 | my $option = lc($1); |
126 | |
127 | $default = $arg if ($option eq 'default'); |
128 | $conflict = $arg if ($option eq 'conflict'); |
129 | @tests = @{$arg} if ($option eq 'tests'); |
130 | @skiptests = @{$arg} if ($option eq 'skiptests'); |
131 | |
132 | next; |
133 | } |
134 | |
135 | printf("- %-${maxlen}s ...", $mod); |
136 | |
137 | # XXX: check for conflicts and uninstalls(!) them. |
138 | if (defined(my $cur = _version_check(_load($mod), $arg ||= 0))) { |
139 | print "loaded. ($cur".($arg ? " >= $arg" : '').")\n"; |
140 | push @Existing, $mod => $arg; |
141 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; |
142 | } |
143 | else { |
144 | print "missing." . ($arg ? " (would need $arg)" : '') . "\n"; |
145 | push @required, $mod => $arg; |
146 | } |
147 | } |
148 | |
149 | next unless @required; |
150 | |
151 | my $mandatory = ($feature eq '-core' or $core_all); |
152 | |
153 | if (!$SkipInstall and ($CheckOnly or _prompt( |
154 | qq{==> Auto-install the }. (@required / 2). |
155 | ($mandatory ? ' mandatory' : ' optional'). |
156 | qq{ module(s) from CPAN?}, $default ? 'y' : 'n', |
157 | ) =~ /^[Yy]/)) { |
158 | push (@Missing, @required); |
159 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; |
160 | } |
161 | |
162 | elsif (!$SkipInstall and $default and $mandatory and _prompt( |
163 | qq{==> The module(s) are mandatory! Really skip?}, 'n', |
164 | ) =~ /^[Nn]/) { |
165 | push (@Missing, @required); |
166 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; |
167 | } |
168 | |
169 | else { |
170 | $DisabledTests{$_} = 1 for map { glob($_) } @tests; |
171 | } |
172 | } |
173 | |
174 | _check_lock(); # check for $UnderCPAN |
175 | |
176 | if (@Missing and not ($CheckOnly or $UnderCPAN)) { |
177 | require Config; |
178 | print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; |
179 | # make an educated guess of whether we'll need root permission. |
180 | print " (You may need to do that as the 'root' user.)\n" if eval '$>'; |
181 | } |
182 | print "*** $class configuration finished.\n"; |
183 | |
184 | chdir $cwd; |
185 | |
186 | # import to main:: |
187 | no strict 'refs'; |
188 | *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; |
189 | } |
190 | |
191 | # CPAN.pm is non-reentrant, so check if we're under it and have no CPANPLUS |
192 | sub _check_lock { |
193 | return unless @Missing; |
194 | return if _has_cpanplus(); |
195 | |
196 | require CPAN; CPAN::Config->load; |
197 | my $lock = MM->catfile($CPAN::Config->{cpan_home}, ".lock"); |
198 | |
199 | if (-f $lock and open(LOCK, $lock) |
200 | and ($^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid()) |
201 | and ($CPAN::Config->{prerequisites_policy} || '') ne 'ignore' |
202 | ) { |
203 | print << '.'; |
204 | |
205 | *** Since we're running under CPAN, I'll just let it take care |
206 | of the dependency's installation later. |
207 | . |
208 | $UnderCPAN = 1; |
209 | } |
210 | |
211 | close LOCK; |
212 | } |
213 | |
214 | sub install { |
215 | my $class = shift; |
216 | |
217 | my $i; # used below to strip leading '-' from config keys |
218 | my @config = (map { s/^-// if ++$i; $_ } @{+shift}); |
219 | |
220 | my (@modules, @installed); |
221 | while (my ($pkg, $ver) = splice(@_, 0, 2)) { |
222 | # grep out those already installed |
223 | if (defined(_version_check(_load($pkg), $ver))) { |
224 | push @installed, $pkg; |
225 | } |
226 | else { |
227 | push @modules, $pkg, $ver; |
228 | } |
229 | } |
230 | |
231 | return @installed unless @modules; # nothing to do |
232 | |
233 | print "*** Installing dependencies...\n"; |
234 | |
235 | return unless _connected_to('cpan.org'); |
236 | |
237 | my %args = @config; |
238 | my %failed; |
239 | local *FAILED; |
240 | if ($args{do_once} and open(FAILED, '.#autoinstall.failed')) { |
241 | while (<FAILED>) { chomp; $failed{$_}++ } |
242 | close FAILED; |
243 | |
244 | my @newmod; |
245 | while (my ($k, $v) = splice(@modules, 0, 2)) { |
246 | push @newmod, ($k => $v) unless $failed{$k}; |
247 | } |
248 | @modules = @newmod; |
249 | } |
250 | |
251 | if (_has_cpanplus()) { |
252 | _install_cpanplus(\@modules, \@config); |
253 | } |
254 | else { |
255 | _install_cpan(\@modules, \@config); |
256 | } |
257 | |
258 | print "*** $class installation finished.\n"; |
259 | |
260 | # see if we have successfully installed them |
261 | while (my ($pkg, $ver) = splice(@modules, 0, 2)) { |
262 | if (defined(_version_check(_load($pkg), $ver))) { |
263 | push @installed, $pkg; |
264 | } |
265 | elsif ($args{do_once} and open(FAILED, '>> .#autoinstall.failed')) { |
266 | print FAILED "$pkg\n"; |
267 | } |
268 | } |
269 | |
270 | close FAILED if $args{do_once}; |
271 | |
272 | return @installed; |
273 | } |
274 | |
275 | sub _install_cpanplus { |
276 | my @modules = @{+shift}; |
277 | my @config = @{+shift}; |
278 | my $installed = 0; |
279 | |
280 | require CPANPLUS::Backend; |
281 | my $cp = CPANPLUS::Backend->new; |
282 | my $conf = $cp->configure_object; |
283 | |
284 | return unless _can_write($conf->_get_build('base')); |
285 | |
286 | # if we're root, set UNINST=1 to avoid trouble unless user asked for it. |
287 | my $makeflags = $conf->get_conf('makeflags') || ''; |
288 | if (UNIVERSAL::isa($makeflags, 'HASH')) { |
289 | # 0.03+ uses a hashref here |
290 | $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; |
291 | } |
292 | else { |
293 | # 0.02 and below uses a scalar |
294 | $makeflags = join(' ', split(' ', $makeflags), 'UNINST=1') |
295 | if ($makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' }); |
296 | } |
297 | $conf->set_conf(makeflags => $makeflags); |
298 | |
299 | while (my ($key, $val) = splice(@config, 0, 2)) { |
300 | eval { $conf->set_conf($key, $val) }; |
301 | } |
302 | |
303 | my $modtree = $cp->module_tree; |
304 | while (my ($pkg, $ver) = splice(@modules, 0, 2)) { |
305 | print "*** Installing $pkg...\n"; |
306 | |
307 | MY::preinstall($pkg, $ver) or next if defined &MY::preinstall; |
308 | |
309 | my $success; |
310 | my $obj = $modtree->{$pkg}; |
311 | |
312 | if ($obj and defined(_version_check($obj->{version}, $ver))) { |
313 | my $pathname = $pkg; $pathname =~ s/::/\\W/; |
314 | |
315 | foreach my $inc (grep { m/$pathname.pm/i } keys(%INC)) { |
316 | delete $INC{$inc}; |
317 | } |
318 | |
319 | my $rv = $cp->install( modules => [ $obj->{module} ]); |
320 | |
321 | if ($rv and ($rv->{$obj->{module}} or $rv->{ok})) { |
322 | print "*** $pkg successfully installed.\n"; |
323 | $success = 1; |
324 | } |
325 | else { |
326 | print "*** $pkg installation cancelled.\n"; |
327 | $success = 0; |
328 | } |
329 | |
330 | $installed += $success; |
331 | } |
332 | else { |
333 | print << "."; |
334 | *** Could not find a version $ver or above for $pkg; skipping. |
335 | . |
336 | } |
337 | |
338 | MY::postinstall($pkg, $ver, $success) if defined &MY::postinstall; |
339 | } |
340 | |
341 | return $installed; |
342 | } |
343 | |
344 | sub _install_cpan { |
345 | my @modules = @{+shift}; |
346 | my @config = @{+shift}; |
347 | my $installed = 0; |
348 | my %args; |
349 | |
350 | require CPAN; CPAN::Config->load; |
351 | |
352 | return unless _can_write(MM->catfile($CPAN::Config->{cpan_home}, 'sources')); |
353 | |
354 | # if we're root, set UNINST=1 to avoid trouble unless user asked for it. |
355 | my $makeflags = $CPAN::Config->{make_install_arg} || ''; |
356 | $CPAN::Config->{make_install_arg} = join(' ', split(' ', $makeflags), 'UNINST=1') |
357 | if ($makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' }); |
358 | |
359 | # don't show start-up info |
360 | $CPAN::Config->{inhibit_startup_message} = 1; |
361 | |
362 | # set additional options |
363 | while (my ($opt, $arg) = splice(@config, 0, 2)) { |
364 | ($args{$opt} = $arg, next) |
365 | if $opt =~ /^force$/; # pseudo-option |
366 | $CPAN::Config->{$opt} = $arg; |
367 | } |
368 | |
369 | while (my ($pkg, $ver) = splice(@modules, 0, 2)) { |
370 | MY::preinstall($pkg, $ver) or next if defined &MY::preinstall; |
371 | |
372 | print "*** Installing $pkg...\n"; |
373 | |
374 | my $obj = CPAN::Shell->expand(Module => $pkg); |
375 | my $success = 0; |
376 | |
377 | if ($obj and defined(_version_check($obj->cpan_version, $ver))) { |
378 | my $pathname = $pkg; $pathname =~ s/::/\\W/; |
379 | |
380 | foreach my $inc (grep { m/$pathname.pm/i } keys(%INC)) { |
381 | delete $INC{$inc}; |
382 | } |
383 | |
384 | $obj->force('install') if $args{force}; |
385 | |
386 | if ($obj->install eq 'YES') { |
387 | print "*** $pkg successfully installed.\n"; |
388 | $success = 1; |
389 | } |
390 | else { |
391 | print "*** $pkg installation failed.\n"; |
392 | $success = 0; |
393 | } |
394 | |
395 | $installed += $success; |
396 | } |
397 | else { |
398 | print << "."; |
399 | *** Could not find a version $ver or above for $pkg; skipping. |
400 | . |
401 | } |
402 | |
403 | MY::postinstall($pkg, $ver, $success) if defined &MY::postinstall; |
404 | } |
405 | |
406 | return $installed; |
407 | } |
408 | |
409 | sub _has_cpanplus { |
410 | return ( |
411 | $HasCPANPLUS = ( |
412 | $INC{'CPANPLUS/Config.pm'} or |
413 | _load('CPANPLUS::Shell::Default') |
414 | ) |
415 | ); |
416 | } |
417 | |
418 | # make guesses on whether we're under the CPAN installation directory |
419 | sub _under_cpan { |
420 | require Cwd; |
421 | require File::Spec; |
422 | |
423 | my $cwd = File::Spec->canonpath(Cwd::cwd()); |
424 | my $cpan = File::Spec->canonpath($CPAN::Config->{cpan_home}); |
425 | |
426 | return (index($cwd, $cpan) > -1); |
427 | } |
428 | |
429 | sub _update_to { |
430 | my $class = __PACKAGE__; |
431 | my $ver = shift; |
432 | |
433 | return if defined(_version_check(_load($class), $ver)); # no need to upgrade |
434 | |
435 | if (_prompt( |
436 | "==> A newer version of $class ($ver) is required. Install?", 'y' |
437 | ) =~ /^[Nn]/) { |
438 | die "*** Please install $class $ver manually.\n"; |
439 | } |
440 | |
441 | print << "."; |
442 | *** Trying to fetch it from CPAN... |
443 | . |
444 | |
445 | # install ourselves |
446 | _load($class) and return $class->import(@_) |
447 | if $class->install([], $class, $ver); |
448 | |
449 | print << '.'; exit 1; |
450 | |
451 | *** Cannot bootstrap myself. :-( Installation terminated. |
452 | . |
453 | } |
454 | |
455 | # check if we're connected to some host, using inet_aton |
456 | sub _connected_to { |
457 | my $site = shift; |
458 | |
459 | return ( |
460 | ( _load('Socket') and Socket::inet_aton($site) ) or _prompt(qq( |
461 | *** Your host cannot resolve the domain name '$site', which |
462 | probably means the Internet connections are unavailable. |
463 | ==> Should we try to install the required module(s) anyway?), 'n' |
464 | ) =~ /^[Yy]/ |
465 | ); |
466 | } |
467 | |
468 | # check if a directory is writable; may create it on demand |
469 | sub _can_write { |
470 | my $path = shift; |
471 | mkdir ($path, 0755) unless -e $path; |
472 | |
473 | require Config; |
474 | return 1 if -w $path and -w $Config::Config{sitelib}; |
475 | |
476 | print << "."; |
477 | *** You are not allowed to write to the directory '$path'; |
478 | the installation may fail due to insufficient permissions. |
479 | . |
480 | |
481 | if (eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(qq( |
482 | ==> Should we try to re-execute the autoinstall process with 'sudo'?), 'y' |
483 | ) =~ /^[Yy]/) { |
484 | # try to bootstrap ourselves from sudo |
485 | print << "."; |
486 | *** Trying to re-execute the autoinstall process with 'sudo'... |
487 | . |
488 | my $missing = join(',', @Missing); |
489 | my $config = join(',', |
490 | UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config} |
491 | ) if $Config; |
492 | |
493 | return unless system('sudo', $^X, $0, "--config=$config", "--installdeps=$missing"); |
494 | |
495 | print << "."; |
496 | *** The 'sudo' command exited with error! Resuming... |
497 | . |
498 | } |
499 | |
500 | return _prompt(qq( |
501 | ==> Should we try to install the required module(s) anyway?), 'n' |
502 | ) =~ /^[Yy]/ |
503 | } |
504 | |
505 | # load a module and return the version it reports |
506 | sub _load { |
507 | my $mod = pop; # class/instance doesn't matter |
508 | my $file = $mod; |
509 | |
510 | $file =~ s|::|/|g; |
511 | $file .= '.pm'; |
512 | |
513 | local $@; |
514 | return eval { require $file; $mod->VERSION } || ($@ ? undef : 0); |
515 | } |
516 | |
517 | # compare two versions, either use Sort::Versions or plain comparison |
518 | sub _version_check { |
519 | my ($cur, $min) = @_; |
520 | return unless defined $cur; |
521 | |
522 | $cur =~ s/\s+$//; |
523 | |
524 | # check for version numbers that are not in decimal format |
525 | if (ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./) { |
526 | if ($version::VERSION or defined(_load('version'))) { |
527 | # use version.pm if it is installed. |
528 | return ((version->new($cur) >= version->new($min)) ? $cur : undef); |
529 | } |
530 | elsif ($Sort::Versions::VERSION or defined(_load('Sort::Versions'))) { |
531 | # use Sort::Versions as the sorting algorithm for a.b.c versions |
532 | return ((Sort::Versions::versioncmp($cur, $min) != -1) ? $cur : undef); |
533 | } |
534 | |
535 | warn "Cannot reliably compare non-decimal formatted versions.\n". |
536 | "Please install version.pm or Sort::Versions.\n"; |
537 | } |
538 | |
539 | # plain comparison |
540 | local $^W = 0; # shuts off 'not numeric' bugs |
541 | return ($cur >= $min ? $cur : undef); |
542 | } |
543 | |
544 | # nothing; this usage is deprecated. |
545 | sub main::PREREQ_PM { return {}; } |
546 | |
547 | sub _make_args { |
548 | my %args = @_; |
549 | |
550 | $args{PREREQ_PM} = { %{$args{PREREQ_PM} || {} }, @Existing, @Missing } |
551 | if $UnderCPAN or $TestOnly; |
552 | |
553 | if ($args{EXE_FILES}) { |
554 | require ExtUtils::Manifest; |
555 | my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); |
556 | |
557 | $args{EXE_FILES} = [ |
558 | grep { exists $manifest->{$_} } @{$args{EXE_FILES}} |
559 | ]; |
560 | } |
561 | |
562 | $args{test}{TESTS} ||= 't/*.t'; |
563 | $args{test}{TESTS} = join(' ', grep { |
564 | !exists($DisabledTests{$_}) |
565 | } map { glob($_) } split(/\s+/, $args{test}{TESTS})); |
566 | |
567 | my $missing = join(',', @Missing); |
568 | my $config = join(',', |
569 | UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config} |
570 | ) if $Config; |
571 | |
572 | $PostambleActions = ( |
573 | $missing ? "\$(PERL) $0 --config=$config --installdeps=$missing" |
574 | : "\@\$(NOOP)" |
575 | ); |
576 | |
577 | return %args; |
578 | } |
579 | |
580 | # a wrapper to ExtUtils::MakeMaker::WriteMakefile |
581 | sub Write { |
582 | require Carp; |
583 | Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; |
584 | |
585 | if ($CheckOnly) { |
586 | print << "."; |
587 | *** Makefile not written in check-only mode. |
588 | . |
589 | return; |
590 | } |
591 | |
592 | my %args = _make_args(@_); |
593 | |
594 | no strict 'refs'; |
595 | |
596 | $PostambleUsed = 0; |
597 | local *MY::postamble = \&postamble unless defined &MY::postamble; |
598 | ExtUtils::MakeMaker::WriteMakefile(%args); |
599 | |
600 | print << "." unless $PostambleUsed; |
601 | *** WARNING: Makefile written with customized MY::postamble() without |
602 | including contents from ExtUtils::AutoInstall::postamble() -- |
603 | auto installation features disabled. Please contact the author. |
604 | . |
605 | |
606 | return 1; |
607 | } |
608 | |
609 | sub postamble { |
610 | $PostambleUsed = 1; |
611 | |
612 | return << "."; |
613 | |
614 | config :: installdeps |
615 | \t\@\$(NOOP) |
616 | |
617 | checkdeps :: |
618 | \t\$(PERL) $0 --checkdeps |
619 | |
620 | installdeps :: |
621 | \t$PostambleActions |
622 | |
623 | . |
624 | |
625 | } |
626 | |
627 | 1; |
628 | |
629 | __END__ |
630 | |
ecac864a |
631 | #line 928 |