X-Git-Url: http://erislabs.net/gitweb/?p=libwww-opensearch-perl.git;a=blobdiff_plain;f=inc%2FModule%2FInstall.pm;fp=inc%2FModule%2FInstall.pm;h=5871e1e1b2842b34cdf57f264ca74fb9fcb1cc10;hp=51eda5de20c85ecec5ed7dae95e1e57ab0aee30f;hb=70fa825da53bce7cee2d56a3a9d3cbeb2b4c7076;hpb=85d58c49caf33a66fdee3b54c6fda4981c7a8d47 diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm index 51eda5d..5871e1e 100644 --- a/inc/Module/Install.pm +++ b/inc/Module/Install.pm @@ -19,6 +19,10 @@ package Module::Install; use 5.005; use strict 'vars'; +use Cwd (); +use File::Find (); +use File::Path (); +use FindBin; use vars qw{$VERSION $MAIN}; BEGIN { @@ -28,7 +32,7 @@ BEGIN { # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. - $VERSION = '0.91'; + $VERSION = '0.97'; # Storage for the pseudo-singleton $MAIN = undef; @@ -38,18 +42,25 @@ BEGIN { } +sub import { + my $class = shift; + my $self = $class->new(@_); + my $who = $self->_caller; - - - -# Whether or not inc::Module::Install is actually loaded, the -# $INC{inc/Module/Install.pm} is what will still get set as long as -# the caller loaded module this in the documented manner. -# If not set, the caller may NOT have loaded the bundled version, and thus -# they may not have a MI version that works with the Makefile.PL. This would -# result in false errors or unexpected behaviour. And we don't want that. -my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; -unless ( $INC{$file} ) { die <<"END_DIE" } + #------------------------------------------------------------- + # all of the following checks should be included in import(), + # to allow "eval 'require Module::Install; 1' to test + # installation of Module::Install. (RT #51267) + #------------------------------------------------------------- + + # Whether or not inc::Module::Install is actually loaded, the + # $INC{inc/Module/Install.pm} is what will still get set as long as + # the caller loaded module this in the documented manner. + # If not set, the caller may NOT have loaded the bundled version, and thus + # they may not have a MI version that works with the Makefile.PL. This would + # result in false errors or unexpected behaviour. And we don't want that. + my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; + unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: @@ -61,26 +72,28 @@ not: END_DIE - - - - -# If the script that is loading Module::Install is from the future, -# then make will detect this and cause it to re-run over and over -# again. This is bad. Rather than taking action to touch it (which -# is unreliable on some platforms and requires write permissions) -# for now we should catch this and refuse to run. -if ( -f $0 ) { - my $s = (stat($0))[9]; - - # If the modification time is only slightly in the future, - # sleep briefly to remove the problem. - my $a = $s - time; - if ( $a > 0 and $a < 5 ) { sleep 5 } - - # Too far in the future, throw an error. - my $t = time; - if ( $s > $t ) { die <<"END_DIE" } + # This reportedly fixes a rare Win32 UTC file time issue, but + # as this is a non-cross-platform XS module not in the core, + # we shouldn't really depend on it. See RT #24194 for detail. + # (Also, this module only supports Perl 5.6 and above). + eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; + + # If the script that is loading Module::Install is from the future, + # then make will detect this and cause it to re-run over and over + # again. This is bad. Rather than taking action to touch it (which + # is unreliable on some platforms and requires write permissions) + # for now we should catch this and refuse to run. + if ( -f $0 ) { + my $s = (stat($0))[9]; + + # If the modification time is only slightly in the future, + # sleep briefly to remove the problem. + my $a = $s - time; + if ( $a > 0 and $a < 5 ) { sleep 5 } + + # Too far in the future, throw an error. + my $t = time; + if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). @@ -89,15 +102,12 @@ This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE -} - - - + } -# Build.PL was formerly supported, but no longer is due to excessive -# difficulty in implementing every single feature twice. -if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } + # Build.PL was formerly supported, but no longer is due to excessive + # difficulty in implementing every single feature twice. + if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. @@ -107,23 +117,42 @@ Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE + #------------------------------------------------------------- + # To save some more typing in Module::Install installers, every... + # use inc::Module::Install + # ...also acts as an implicit use strict. + $^H |= strict::bits(qw(refs subs vars)); + #------------------------------------------------------------- + unless ( -f $self->{file} ) { + foreach my $key (keys %INC) { + delete $INC{$key} if $key =~ /Module\/Install/; + } -# To save some more typing in Module::Install installers, every... -# use inc::Module::Install -# ...also acts as an implicit use strict. -$^H |= strict::bits(qw(refs subs vars)); - + local $^W; + require "$self->{path}/$self->{dispatch}.pm"; + File::Path::mkpath("$self->{prefix}/$self->{author}"); + $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); + $self->{admin}->init; + @_ = ($class, _self => $self); + goto &{"$self->{name}::import"}; + } + local $^W; + *{"${who}::AUTOLOAD"} = $self->autoload; + $self->preload; + # Unregister loader and worker packages so subdirs can use them again + delete $INC{'inc/Module/Install.pm'}; + delete $INC{'Module/Install.pm'}; + # Save to the singleton + $MAIN = $self; -use Cwd (); -use File::Find (); -use File::Path (); -use FindBin; + return 1; +} sub autoload { my $self = shift; @@ -136,7 +165,21 @@ sub autoload { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } - $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; + unless ($$sym =~ s/([^:]+)$//) { + # XXX: it looks like we can't retrieve the missing function + # via $$sym (usually $main::AUTOLOAD) in this case. + # I'm still wondering if we should slurp Makefile.PL to + # get some context or not ... + my ($package, $file, $line) = caller; + die <<"EOT"; +Unknown function is found at $file line $line. +Execution of $file aborted due to runtime errors. + +If you're a contributor to a project, you may need to install +some Module::Install extensions from CPAN (or other repository). +If you're a user of a module, please contact the author. +EOT + } my $method = $1; if ( uc($method) eq $method ) { # Do nothing @@ -152,33 +195,6 @@ sub autoload { }; } -sub import { - my $class = shift; - my $self = $class->new(@_); - my $who = $self->_caller; - - unless ( -f $self->{file} ) { - require "$self->{path}/$self->{dispatch}.pm"; - File::Path::mkpath("$self->{prefix}/$self->{author}"); - $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); - $self->{admin}->init; - @_ = ($class, _self => $self); - goto &{"$self->{name}::import"}; - } - - *{"${who}::AUTOLOAD"} = $self->autoload; - $self->preload; - - # Unregister loader and worker packages so subdirs can use them again - delete $INC{"$self->{file}"}; - delete $INC{"$self->{path}.pm"}; - - # Save to the singleton - $MAIN = $self; - - return 1; -} - sub preload { my $self = shift; unless ( $self->{extensions} ) { @@ -204,6 +220,7 @@ sub preload { my $who = $self->_caller; foreach my $name ( sort keys %seen ) { + local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; @@ -214,12 +231,13 @@ sub preload { sub new { my ($class, %args) = @_; + FindBin->again; + # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } - return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; @@ -272,8 +290,10 @@ END_DIE sub load_extensions { my ($self, $path, $top) = @_; + my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; + $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { @@ -281,12 +301,13 @@ sub load_extensions { next if $self->{pathnames}{$pkg}; local $@; - my $new = eval { require $file; $pkg->can('new') }; + my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } - $self->{pathnames}{$pkg} = delete $INC{$file}; + $self->{pathnames}{$pkg} = + $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } @@ -348,17 +369,24 @@ sub _caller { return $call; } +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; - if ( $] >= 5.006 ) { - open( FH, '<', $_[0] ) or die "open($_[0]): $!"; - } else { - open( FH, "< $_[0]" ) or die "open($_[0]): $!"; - } + open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } +END_NEW +sub _read { + local *FH; + open( FH, "< $_[0]" ) or die "open($_[0]): $!"; + my $string = do { local $/; }; + close FH or die "close($_[0]): $!"; + return $string; +} +END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); @@ -379,18 +407,26 @@ sub _readpod { return $string; } +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; - if ( $] >= 5.006 ) { - open( FH, '>', $_[0] ) or die "open($_[0]): $!"; - } else { - open( FH, "> $_[0]" ) or die "open($_[0]): $!"; + open( FH, '>', $_[0] ) or die "open($_[0]): $!"; + foreach ( 1 .. $#_ ) { + print FH $_[$_] or die "print($_[0]): $!"; } + close FH or die "close($_[0]): $!"; +} +END_NEW +sub _write { + local *FH; + open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } +END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). @@ -427,4 +463,4 @@ sub _CLASS ($) { 1; -# Copyright 2008 - 2009 Adam Kennedy. +# Copyright 2008 - 2010 Adam Kennedy.