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