[24bd860] | 1 | #line 1 |
---|
| 2 | package Module::Install; |
---|
| 3 | |
---|
| 4 | # For any maintainers: |
---|
| 5 | # The load order for Module::Install is a bit magic. |
---|
| 6 | # It goes something like this... |
---|
| 7 | # |
---|
| 8 | # IF ( host has Module::Install installed, creating author mode ) { |
---|
| 9 | # 1. Makefile.PL calls "use inc::Module::Install" |
---|
| 10 | # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install |
---|
| 11 | # 3. The installed version of inc::Module::Install loads |
---|
| 12 | # 4. inc::Module::Install calls "require Module::Install" |
---|
| 13 | # 5. The ./inc/ version of Module::Install loads |
---|
| 14 | # } ELSE { |
---|
| 15 | # 1. Makefile.PL calls "use inc::Module::Install" |
---|
| 16 | # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install |
---|
| 17 | # 3. The ./inc/ version of Module::Install loads |
---|
| 18 | # } |
---|
| 19 | |
---|
| 20 | use 5.005; |
---|
| 21 | use strict 'vars'; |
---|
| 22 | |
---|
| 23 | use vars qw{$VERSION $MAIN}; |
---|
| 24 | BEGIN { |
---|
| 25 | # All Module::Install core packages now require synchronised versions. |
---|
| 26 | # This will be used to ensure we don't accidentally load old or |
---|
| 27 | # different versions of modules. |
---|
| 28 | # This is not enforced yet, but will be some time in the next few |
---|
| 29 | # releases once we can make sure it won't clash with custom |
---|
| 30 | # Module::Install extensions. |
---|
| 31 | $VERSION = '0.91'; |
---|
| 32 | |
---|
| 33 | # Storage for the pseudo-singleton |
---|
| 34 | $MAIN = undef; |
---|
| 35 | |
---|
| 36 | *inc::Module::Install::VERSION = *VERSION; |
---|
| 37 | @inc::Module::Install::ISA = __PACKAGE__; |
---|
| 38 | |
---|
| 39 | } |
---|
| 40 | |
---|
| 41 | |
---|
| 42 | |
---|
| 43 | |
---|
| 44 | |
---|
| 45 | # Whether or not inc::Module::Install is actually loaded, the |
---|
| 46 | # $INC{inc/Module/Install.pm} is what will still get set as long as |
---|
| 47 | # the caller loaded module this in the documented manner. |
---|
| 48 | # If not set, the caller may NOT have loaded the bundled version, and thus |
---|
| 49 | # they may not have a MI version that works with the Makefile.PL. This would |
---|
| 50 | # result in false errors or unexpected behaviour. And we don't want that. |
---|
| 51 | my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; |
---|
| 52 | unless ( $INC{$file} ) { die <<"END_DIE" } |
---|
| 53 | |
---|
| 54 | Please invoke ${\__PACKAGE__} with: |
---|
| 55 | |
---|
| 56 | use inc::${\__PACKAGE__}; |
---|
| 57 | |
---|
| 58 | not: |
---|
| 59 | |
---|
| 60 | use ${\__PACKAGE__}; |
---|
| 61 | |
---|
| 62 | END_DIE |
---|
| 63 | |
---|
| 64 | |
---|
| 65 | |
---|
| 66 | |
---|
| 67 | |
---|
| 68 | # If the script that is loading Module::Install is from the future, |
---|
| 69 | # then make will detect this and cause it to re-run over and over |
---|
| 70 | # again. This is bad. Rather than taking action to touch it (which |
---|
| 71 | # is unreliable on some platforms and requires write permissions) |
---|
| 72 | # for now we should catch this and refuse to run. |
---|
| 73 | if ( -f $0 ) { |
---|
| 74 | my $s = (stat($0))[9]; |
---|
| 75 | |
---|
| 76 | # If the modification time is only slightly in the future, |
---|
| 77 | # sleep briefly to remove the problem. |
---|
| 78 | my $a = $s - time; |
---|
| 79 | if ( $a > 0 and $a < 5 ) { sleep 5 } |
---|
| 80 | |
---|
| 81 | # Too far in the future, throw an error. |
---|
| 82 | my $t = time; |
---|
| 83 | if ( $s > $t ) { die <<"END_DIE" } |
---|
| 84 | |
---|
| 85 | Your installer $0 has a modification time in the future ($s > $t). |
---|
| 86 | |
---|
| 87 | This is known to create infinite loops in make. |
---|
| 88 | |
---|
| 89 | Please correct this, then run $0 again. |
---|
| 90 | |
---|
| 91 | END_DIE |
---|
| 92 | } |
---|
| 93 | |
---|
| 94 | |
---|
| 95 | |
---|
| 96 | |
---|
| 97 | |
---|
| 98 | # Build.PL was formerly supported, but no longer is due to excessive |
---|
| 99 | # difficulty in implementing every single feature twice. |
---|
| 100 | if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } |
---|
| 101 | |
---|
| 102 | Module::Install no longer supports Build.PL. |
---|
| 103 | |
---|
| 104 | It was impossible to maintain duel backends, and has been deprecated. |
---|
| 105 | |
---|
| 106 | Please remove all Build.PL files and only use the Makefile.PL installer. |
---|
| 107 | |
---|
| 108 | END_DIE |
---|
| 109 | |
---|
| 110 | |
---|
| 111 | |
---|
| 112 | |
---|
| 113 | |
---|
| 114 | # To save some more typing in Module::Install installers, every... |
---|
| 115 | # use inc::Module::Install |
---|
| 116 | # ...also acts as an implicit use strict. |
---|
| 117 | $^H |= strict::bits(qw(refs subs vars)); |
---|
| 118 | |
---|
| 119 | |
---|
| 120 | |
---|
| 121 | |
---|
| 122 | |
---|
| 123 | use Cwd (); |
---|
| 124 | use File::Find (); |
---|
| 125 | use File::Path (); |
---|
| 126 | use FindBin; |
---|
| 127 | |
---|
| 128 | sub autoload { |
---|
| 129 | my $self = shift; |
---|
| 130 | my $who = $self->_caller; |
---|
| 131 | my $cwd = Cwd::cwd(); |
---|
| 132 | my $sym = "${who}::AUTOLOAD"; |
---|
| 133 | $sym->{$cwd} = sub { |
---|
| 134 | my $pwd = Cwd::cwd(); |
---|
| 135 | if ( my $code = $sym->{$pwd} ) { |
---|
| 136 | # Delegate back to parent dirs |
---|
| 137 | goto &$code unless $cwd eq $pwd; |
---|
| 138 | } |
---|
| 139 | $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; |
---|
| 140 | my $method = $1; |
---|
| 141 | if ( uc($method) eq $method ) { |
---|
| 142 | # Do nothing |
---|
| 143 | return; |
---|
| 144 | } elsif ( $method =~ /^_/ and $self->can($method) ) { |
---|
| 145 | # Dispatch to the root M:I class |
---|
| 146 | return $self->$method(@_); |
---|
| 147 | } |
---|
| 148 | |
---|
| 149 | # Dispatch to the appropriate plugin |
---|
| 150 | unshift @_, ( $self, $1 ); |
---|
| 151 | goto &{$self->can('call')}; |
---|
| 152 | }; |
---|
| 153 | } |
---|
| 154 | |
---|
| 155 | sub import { |
---|
| 156 | my $class = shift; |
---|
| 157 | my $self = $class->new(@_); |
---|
| 158 | my $who = $self->_caller; |
---|
| 159 | |
---|
| 160 | unless ( -f $self->{file} ) { |
---|
| 161 | require "$self->{path}/$self->{dispatch}.pm"; |
---|
| 162 | File::Path::mkpath("$self->{prefix}/$self->{author}"); |
---|
| 163 | $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); |
---|
| 164 | $self->{admin}->init; |
---|
| 165 | @_ = ($class, _self => $self); |
---|
| 166 | goto &{"$self->{name}::import"}; |
---|
| 167 | } |
---|
| 168 | |
---|
| 169 | *{"${who}::AUTOLOAD"} = $self->autoload; |
---|
| 170 | $self->preload; |
---|
| 171 | |
---|
| 172 | # Unregister loader and worker packages so subdirs can use them again |
---|
| 173 | delete $INC{"$self->{file}"}; |
---|
| 174 | delete $INC{"$self->{path}.pm"}; |
---|
| 175 | |
---|
| 176 | # Save to the singleton |
---|
| 177 | $MAIN = $self; |
---|
| 178 | |
---|
| 179 | return 1; |
---|
| 180 | } |
---|
| 181 | |
---|
| 182 | sub preload { |
---|
| 183 | my $self = shift; |
---|
| 184 | unless ( $self->{extensions} ) { |
---|
| 185 | $self->load_extensions( |
---|
| 186 | "$self->{prefix}/$self->{path}", $self |
---|
| 187 | ); |
---|
| 188 | } |
---|
| 189 | |
---|
| 190 | my @exts = @{$self->{extensions}}; |
---|
| 191 | unless ( @exts ) { |
---|
| 192 | @exts = $self->{admin}->load_all_extensions; |
---|
| 193 | } |
---|
| 194 | |
---|
| 195 | my %seen; |
---|
| 196 | foreach my $obj ( @exts ) { |
---|
| 197 | while (my ($method, $glob) = each %{ref($obj) . '::'}) { |
---|
| 198 | next unless $obj->can($method); |
---|
| 199 | next if $method =~ /^_/; |
---|
| 200 | next if $method eq uc($method); |
---|
| 201 | $seen{$method}++; |
---|
| 202 | } |
---|
| 203 | } |
---|
| 204 | |
---|
| 205 | my $who = $self->_caller; |
---|
| 206 | foreach my $name ( sort keys %seen ) { |
---|
| 207 | *{"${who}::$name"} = sub { |
---|
| 208 | ${"${who}::AUTOLOAD"} = "${who}::$name"; |
---|
| 209 | goto &{"${who}::AUTOLOAD"}; |
---|
| 210 | }; |
---|
| 211 | } |
---|
| 212 | } |
---|
| 213 | |
---|
| 214 | sub new { |
---|
| 215 | my ($class, %args) = @_; |
---|
| 216 | |
---|
| 217 | # ignore the prefix on extension modules built from top level. |
---|
| 218 | my $base_path = Cwd::abs_path($FindBin::Bin); |
---|
| 219 | unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { |
---|
| 220 | delete $args{prefix}; |
---|
| 221 | } |
---|
| 222 | |
---|
| 223 | return $args{_self} if $args{_self}; |
---|
| 224 | |
---|
| 225 | $args{dispatch} ||= 'Admin'; |
---|
| 226 | $args{prefix} ||= 'inc'; |
---|
| 227 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); |
---|
| 228 | $args{bundle} ||= 'inc/BUNDLES'; |
---|
| 229 | $args{base} ||= $base_path; |
---|
| 230 | $class =~ s/^\Q$args{prefix}\E:://; |
---|
| 231 | $args{name} ||= $class; |
---|
| 232 | $args{version} ||= $class->VERSION; |
---|
| 233 | unless ( $args{path} ) { |
---|
| 234 | $args{path} = $args{name}; |
---|
| 235 | $args{path} =~ s!::!/!g; |
---|
| 236 | } |
---|
| 237 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; |
---|
| 238 | $args{wrote} = 0; |
---|
| 239 | |
---|
| 240 | bless( \%args, $class ); |
---|
| 241 | } |
---|
| 242 | |
---|
| 243 | sub call { |
---|
| 244 | my ($self, $method) = @_; |
---|
| 245 | my $obj = $self->load($method) or return; |
---|
| 246 | splice(@_, 0, 2, $obj); |
---|
| 247 | goto &{$obj->can($method)}; |
---|
| 248 | } |
---|
| 249 | |
---|
| 250 | sub load { |
---|
| 251 | my ($self, $method) = @_; |
---|
| 252 | |
---|
| 253 | $self->load_extensions( |
---|
| 254 | "$self->{prefix}/$self->{path}", $self |
---|
| 255 | ) unless $self->{extensions}; |
---|
| 256 | |
---|
| 257 | foreach my $obj (@{$self->{extensions}}) { |
---|
| 258 | return $obj if $obj->can($method); |
---|
| 259 | } |
---|
| 260 | |
---|
| 261 | my $admin = $self->{admin} or die <<"END_DIE"; |
---|
| 262 | The '$method' method does not exist in the '$self->{prefix}' path! |
---|
| 263 | Please remove the '$self->{prefix}' directory and run $0 again to load it. |
---|
| 264 | END_DIE |
---|
| 265 | |
---|
| 266 | my $obj = $admin->load($method, 1); |
---|
| 267 | push @{$self->{extensions}}, $obj; |
---|
| 268 | |
---|
| 269 | $obj; |
---|
| 270 | } |
---|
| 271 | |
---|
| 272 | sub load_extensions { |
---|
| 273 | my ($self, $path, $top) = @_; |
---|
| 274 | |
---|
| 275 | unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { |
---|
| 276 | unshift @INC, $self->{prefix}; |
---|
| 277 | } |
---|
| 278 | |
---|
| 279 | foreach my $rv ( $self->find_extensions($path) ) { |
---|
| 280 | my ($file, $pkg) = @{$rv}; |
---|
| 281 | next if $self->{pathnames}{$pkg}; |
---|
| 282 | |
---|
| 283 | local $@; |
---|
| 284 | my $new = eval { require $file; $pkg->can('new') }; |
---|
| 285 | unless ( $new ) { |
---|
| 286 | warn $@ if $@; |
---|
| 287 | next; |
---|
| 288 | } |
---|
| 289 | $self->{pathnames}{$pkg} = delete $INC{$file}; |
---|
| 290 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); |
---|
| 291 | } |
---|
| 292 | |
---|
| 293 | $self->{extensions} ||= []; |
---|
| 294 | } |
---|
| 295 | |
---|
| 296 | sub find_extensions { |
---|
| 297 | my ($self, $path) = @_; |
---|
| 298 | |
---|
| 299 | my @found; |
---|
| 300 | File::Find::find( sub { |
---|
| 301 | my $file = $File::Find::name; |
---|
| 302 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; |
---|
| 303 | my $subpath = $1; |
---|
| 304 | return if lc($subpath) eq lc($self->{dispatch}); |
---|
| 305 | |
---|
| 306 | $file = "$self->{path}/$subpath.pm"; |
---|
| 307 | my $pkg = "$self->{name}::$subpath"; |
---|
| 308 | $pkg =~ s!/!::!g; |
---|
| 309 | |
---|
| 310 | # If we have a mixed-case package name, assume case has been preserved |
---|
| 311 | # correctly. Otherwise, root through the file to locate the case-preserved |
---|
| 312 | # version of the package name. |
---|
| 313 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { |
---|
| 314 | my $content = Module::Install::_read($subpath . '.pm'); |
---|
| 315 | my $in_pod = 0; |
---|
| 316 | foreach ( split //, $content ) { |
---|
| 317 | $in_pod = 1 if /^=\w/; |
---|
| 318 | $in_pod = 0 if /^=cut/; |
---|
| 319 | next if ($in_pod || /^=cut/); # skip pod text |
---|
| 320 | next if /^\s*#/; # and comments |
---|
| 321 | if ( m/^\s*package\s+($pkg)\s*;/i ) { |
---|
| 322 | $pkg = $1; |
---|
| 323 | last; |
---|
| 324 | } |
---|
| 325 | } |
---|
| 326 | } |
---|
| 327 | |
---|
| 328 | push @found, [ $file, $pkg ]; |
---|
| 329 | }, $path ) if -d $path; |
---|
| 330 | |
---|
| 331 | @found; |
---|
| 332 | } |
---|
| 333 | |
---|
| 334 | |
---|
| 335 | |
---|
| 336 | |
---|
| 337 | |
---|
| 338 | ##################################################################### |
---|
| 339 | # Common Utility Functions |
---|
| 340 | |
---|
| 341 | sub _caller { |
---|
| 342 | my $depth = 0; |
---|
| 343 | my $call = caller($depth); |
---|
| 344 | while ( $call eq __PACKAGE__ ) { |
---|
| 345 | $depth++; |
---|
| 346 | $call = caller($depth); |
---|
| 347 | } |
---|
| 348 | return $call; |
---|
| 349 | } |
---|
| 350 | |
---|
| 351 | sub _read { |
---|
| 352 | local *FH; |
---|
| 353 | if ( $] >= 5.006 ) { |
---|
| 354 | open( FH, '<', $_[0] ) or die "open($_[0]): $!"; |
---|
| 355 | } else { |
---|
| 356 | open( FH, "< $_[0]" ) or die "open($_[0]): $!"; |
---|
| 357 | } |
---|
| 358 | my $string = do { local $/; <FH> }; |
---|
| 359 | close FH or die "close($_[0]): $!"; |
---|
| 360 | return $string; |
---|
| 361 | } |
---|
| 362 | |
---|
| 363 | sub _readperl { |
---|
| 364 | my $string = Module::Install::_read($_[0]); |
---|
| 365 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; |
---|
| 366 | $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; |
---|
| 367 | $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; |
---|
| 368 | return $string; |
---|
| 369 | } |
---|
| 370 | |
---|
| 371 | sub _readpod { |
---|
| 372 | my $string = Module::Install::_read($_[0]); |
---|
| 373 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; |
---|
| 374 | return $string if $_[0] =~ /\.pod\z/; |
---|
| 375 | $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; |
---|
| 376 | $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; |
---|
| 377 | $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; |
---|
| 378 | $string =~ s/^\n+//s; |
---|
| 379 | return $string; |
---|
| 380 | } |
---|
| 381 | |
---|
| 382 | sub _write { |
---|
| 383 | local *FH; |
---|
| 384 | if ( $] >= 5.006 ) { |
---|
| 385 | open( FH, '>', $_[0] ) or die "open($_[0]): $!"; |
---|
| 386 | } else { |
---|
| 387 | open( FH, "> $_[0]" ) or die "open($_[0]): $!"; |
---|
| 388 | } |
---|
| 389 | foreach ( 1 .. $#_ ) { |
---|
| 390 | print FH $_[$_] or die "print($_[0]): $!"; |
---|
| 391 | } |
---|
| 392 | close FH or die "close($_[0]): $!"; |
---|
| 393 | } |
---|
| 394 | |
---|
| 395 | # _version is for processing module versions (eg, 1.03_05) not |
---|
| 396 | # Perl versions (eg, 5.8.1). |
---|
| 397 | sub _version ($) { |
---|
| 398 | my $s = shift || 0; |
---|
| 399 | my $d =()= $s =~ /(\.)/g; |
---|
| 400 | if ( $d >= 2 ) { |
---|
| 401 | # Normalise multipart versions |
---|
| 402 | $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; |
---|
| 403 | } |
---|
| 404 | $s =~ s/^(\d+)\.?//; |
---|
| 405 | my $l = $1 || 0; |
---|
| 406 | my @v = map { |
---|
| 407 | $_ . '0' x (3 - length $_) |
---|
| 408 | } $s =~ /(\d{1,3})\D?/g; |
---|
| 409 | $l = $l . '.' . join '', @v if @v; |
---|
| 410 | return $l + 0; |
---|
| 411 | } |
---|
| 412 | |
---|
| 413 | sub _cmp ($$) { |
---|
| 414 | _version($_[0]) <=> _version($_[1]); |
---|
| 415 | } |
---|
| 416 | |
---|
| 417 | # Cloned from Params::Util::_CLASS |
---|
| 418 | sub _CLASS ($) { |
---|
| 419 | ( |
---|
| 420 | defined $_[0] |
---|
| 421 | and |
---|
| 422 | ! ref $_[0] |
---|
| 423 | and |
---|
| 424 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s |
---|
| 425 | ) ? $_[0] : undef; |
---|
| 426 | } |
---|
| 427 | |
---|
| 428 | 1; |
---|
| 429 | |
---|
| 430 | # Copyright 2008 - 2009 Adam Kennedy. |
---|