inc/Module/Install.pm

#line 1
package Module::Install;

# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
#     1. Makefile.PL calls "use inc::Module::Install"
#     2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
#     3. The installed version of inc::Module::Install loads
#     4. inc::Module::Install calls "require Module::Install"
#     5. The ./inc/ version of Module::Install loads
# } ELSE {
#     1. Makefile.PL calls "use inc::Module::Install"
#     2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
#     3. The ./inc/ version of Module::Install loads
# }

use 5.004;
use strict 'vars';

use vars qw{$VERSION};
BEGIN {
    # All Module::Install core packages now require synchronised versions.
    # This will be used to ensure we don't accidentally load old or
    # different versions of modules.
    # 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.64';
}

# 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:

    use inc::${\__PACKAGE__};

not:

    use ${\__PACKAGE__};

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 and (stat($0))[9] > time ) {
        die << "END_DIE";
Your installer $0 has a modification time in the future.

This is known to create infinite loops in make.

Please correct this, then run $0 again.

END_DIE
}

use Cwd        ();
use File::Find ();
use File::Path ();
use FindBin;

*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA     = __PACKAGE__;

sub autoload {
    my $self = shift;
    my $who  = $self->_caller;
    my $cwd  = Cwd::cwd();
    my $sym  = "${who}::AUTOLOAD";
    $sym->{$cwd} = sub {
        my $pwd = Cwd::cwd();
        if ( my $code = $sym->{$pwd} ) {
            # delegate back to parent dirs
            goto &$code unless $cwd eq $pwd;
        }
        $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
        unshift @_, ($self, $1);
        goto &{$self->can('call')} unless uc($1) eq $1;
    };
}

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"};
}

sub preload {
    my ($self) = @_;

    unless ( $self->{extensions} ) {
        $self->load_extensions(
            "$self->{prefix}/$self->{path}", $self
        );
    }

    my @exts = @{$self->{extensions}};
    unless ( @exts ) {
        my $admin = $self->{admin};
        @exts = $admin->load_all_extensions;
    }

    my %seen;
    foreach my $obj ( @exts ) {
        while (my ($method, $glob) = each %{ref($obj) . '::'}) {
            next unless $obj->can($method);
            next if $method =~ /^_/;
            next if $method eq uc($method);
            $seen{$method}++;
        }
    }

    my $who = $self->_caller;
    foreach my $name ( sort keys %seen ) {
        *{"${who}::$name"} = sub {
            ${"${who}::AUTOLOAD"} = "${who}::$name";
            goto &{"${who}::AUTOLOAD"};
        };
    }
}

sub new {
    my ($class, %args) = @_;

    # 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';
    $args{prefix}   ||= 'inc';
    $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
    $args{bundle}   ||= 'inc/BUNDLES';
    $args{base}     ||= $base_path;
    $class =~ s/^\Q$args{prefix}\E:://;
    $args{name}     ||= $class;
    $args{version}  ||= $class->VERSION;
    unless ( $args{path} ) {
        $args{path}  = $args{name};
        $args{path}  =~ s!::!/!g;
    }
    $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";

    bless( \%args, $class );
}

sub call {
        my ($self, $method) = @_;
        my $obj = $self->load($method) or return;
        splice(@_, 0, 2, $obj);
        goto &{$obj->can($method)};
}

sub load {
    my ($self, $method) = @_;

    $self->load_extensions(
        "$self->{prefix}/$self->{path}", $self
    ) unless $self->{extensions};

    foreach my $obj (@{$self->{extensions}}) {
        return $obj if $obj->can($method);
    }

    my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE

    my $obj = $admin->load($method, 1);
    push @{$self->{extensions}}, $obj;

    $obj;
}

sub load_extensions {
    my ($self, $path, $top) = @_;

    unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
        unshift @INC, $self->{prefix};
    }

    foreach my $rv ( $self->find_extensions($path) ) {
        my ($file, $pkg) = @{$rv};
        next if $self->{pathnames}{$pkg};

        local $@;
        my $new = eval { require $file; $pkg->can('new') };
        unless ( $new ) {
            warn $@ if $@;
            next;
        }
        $self->{pathnames}{$pkg} = delete $INC{$file};
        push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
    }

    $self->{extensions} ||= [];
}

sub find_extensions {
    my ($self, $path) = @_;

    my @found;
    File::Find::find( sub {
        my $file = $File::Find::name;
        return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
        my $subpath = $1;
        return if lc($subpath) eq lc($self->{dispatch});

        $file = "$self->{path}/$subpath.pm";
        my $pkg = "$self->{name}::$subpath";
        $pkg =~ s!/!::!g;

        # If we have a mixed-case package name, assume case has been preserved
        # correctly.  Otherwise, root through the file to locate the case-preserved
        # version of the package name.
        if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
            open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
            my $in_pod = 0;
            while ( <PKGFILE> ) {
                $in_pod = 1 if /^=\w/;
                $in_pod = 0 if /^=cut/;
                next if ($in_pod || /^=cut/);  # skip pod text
                next if /^\s*#/;               # and comments
                if ( m/^\s*package\s+($pkg)\s*;/i ) {
                    $pkg = $1;
                    last;
                }
            }
            close PKGFILE;
        }

        push @found, [ $file, $pkg ];
    }, $path ) if -d $path;

    @found;
}

sub _caller {
    my $depth = 0;
    my $call  = caller($depth);
    while ( $call eq __PACKAGE__ ) {
        $depth++;
        $call = caller($depth);
    }
    return $call;
}

1;
1	dpavlin	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.004;
21			use strict 'vars';
22
23			use vars qw{$VERSION};
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.64';
32			}
33
34			# Whether or not inc::Module::Install is actually loaded, the
35			# $INC{inc/Module/Install.pm} is what will still get set as long as
36			# the caller loaded module this in the documented manner.
37			# If not set, the caller may NOT have loaded the bundled version, and thus
38			# they may not have a MI version that works with the Makefile.PL. This would
39			# result in false errors or unexpected behaviour. And we don't want that.
40			my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
41			unless ( $INC{$file} ) {
42			die <<"END_DIE";
43			Please invoke ${\__PACKAGE__} with:
44
45			use inc::${\__PACKAGE__};
46
47			not:
48
49			use ${\__PACKAGE__};
50
51			END_DIE
52			}
53
54			# If the script that is loading Module::Install is from the future,
55			# then make will detect this and cause it to re-run over and over
56			# again. This is bad. Rather than taking action to touch it (which
57			# is unreliable on some platforms and requires write permissions)
58			# for now we should catch this and refuse to run.
59			if ( -f $0 and (stat($0))[9] > time ) {
60			die << "END_DIE";
61			Your installer $0 has a modification time in the future.
62
63			This is known to create infinite loops in make.
64
65			Please correct this, then run $0 again.
66
67			END_DIE
68			}
69
70			use Cwd ();
71			use File::Find ();
72			use File::Path ();
73			use FindBin;
74
75			inc::Module::Install::VERSION = VERSION;
76			@inc::Module::Install::ISA = __PACKAGE__;
77
78			sub autoload {
79			my $self = shift;
80			my $who = $self->_caller;
81			my $cwd = Cwd::cwd();
82			my $sym = "${who}::AUTOLOAD";
83			$sym->{$cwd} = sub {
84			my $pwd = Cwd::cwd();
85			if ( my $code = $sym->{$pwd} ) {
86			# delegate back to parent dirs
87			goto &$code unless $cwd eq $pwd;
88			}
89			$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
90			unshift @_, ($self, $1);
91			goto &{$self->can('call')} unless uc($1) eq $1;
92			};
93			}
94
95			sub import {
96			my $class = shift;
97			my $self = $class->new(@_);
98			my $who = $self->_caller;
99
100			unless ( -f $self->{file} ) {
101			require "$self->{path}/$self->{dispatch}.pm";
102			File::Path::mkpath("$self->{prefix}/$self->{author}");
103			$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
104			$self->{admin}->init;
105			@_ = ($class, _self => $self);
106			goto &{"$self->{name}::import"};
107			}
108
109			*{"${who}::AUTOLOAD"} = $self->autoload;
110			$self->preload;
111
112			# Unregister loader and worker packages so subdirs can use them again
113			delete $INC{"$self->{file}"};
114			delete $INC{"$self->{path}.pm"};
115			}
116
117			sub preload {
118			my ($self) = @_;
119
120			unless ( $self->{extensions} ) {
121			$self->load_extensions(
122			"$self->{prefix}/$self->{path}", $self
123			);
124			}
125
126			my @exts = @{$self->{extensions}};
127			unless ( @exts ) {
128			my $admin = $self->{admin};
129			@exts = $admin->load_all_extensions;
130			}
131
132			my %seen;
133			foreach my $obj ( @exts ) {
134			while (my ($method, $glob) = each %{ref($obj) . '::'}) {
135			next unless $obj->can($method);
136			next if $method =~ /^_/;
137			next if $method eq uc($method);
138			$seen{$method}++;
139			}
140			}
141
142			my $who = $self->_caller;
143			foreach my $name ( sort keys %seen ) {
144			*{"${who}::$name"} = sub {
145			${"${who}::AUTOLOAD"} = "${who}::$name";
146			goto &{"${who}::AUTOLOAD"};
147			};
148			}
149			}
150
151			sub new {
152			my ($class, %args) = @_;
153
154			# ignore the prefix on extension modules built from top level.
155			my $base_path = Cwd::abs_path($FindBin::Bin);
156			unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
157			delete $args{prefix};
158			}
159
160			return $args{_self} if $args{_self};
161
162			$args{dispatch} \|\|= 'Admin';
163			$args{prefix} \|\|= 'inc';
164			$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
165			$args{bundle} \|\|= 'inc/BUNDLES';
166			$args{base} \|\|= $base_path;
167			$class =~ s/^\Q$args{prefix}\E:://;
168			$args{name} \|\|= $class;
169			$args{version} \|\|= $class->VERSION;
170			unless ( $args{path} ) {
171			$args{path} = $args{name};
172			$args{path} =~ s!::!/!g;
173			}
174			$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
175
176			bless( \%args, $class );
177			}
178
179			sub call {
180			my ($self, $method) = @_;
181			my $obj = $self->load($method) or return;
182			splice(@_, 0, 2, $obj);
183			goto &{$obj->can($method)};
184			}
185
186			sub load {
187			my ($self, $method) = @_;
188
189			$self->load_extensions(
190			"$self->{prefix}/$self->{path}", $self
191			) unless $self->{extensions};
192
193			foreach my $obj (@{$self->{extensions}}) {
194			return $obj if $obj->can($method);
195			}
196
197			my $admin = $self->{admin} or die <<"END_DIE";
198			The '$method' method does not exist in the '$self->{prefix}' path!
199			Please remove the '$self->{prefix}' directory and run $0 again to load it.
200			END_DIE
201
202			my $obj = $admin->load($method, 1);
203			push @{$self->{extensions}}, $obj;
204
205			$obj;
206			}
207
208			sub load_extensions {
209			my ($self, $path, $top) = @_;
210
211			unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
212			unshift @INC, $self->{prefix};
213			}
214
215			foreach my $rv ( $self->find_extensions($path) ) {
216			my ($file, $pkg) = @{$rv};
217			next if $self->{pathnames}{$pkg};
218
219			local $@;
220			my $new = eval { require $file; $pkg->can('new') };
221			unless ( $new ) {
222			warn $@ if $@;
223			next;
224			}
225			$self->{pathnames}{$pkg} = delete $INC{$file};
226			push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
227			}
228
229			$self->{extensions} \|\|= [];
230			}
231
232			sub find_extensions {
233			my ($self, $path) = @_;
234
235			my @found;
236			File::Find::find( sub {
237			my $file = $File::Find::name;
238			return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
239			my $subpath = $1;
240			return if lc($subpath) eq lc($self->{dispatch});
241
242			$file = "$self->{path}/$subpath.pm";
243			my $pkg = "$self->{name}::$subpath";
244			$pkg =~ s!/!::!g;
245
246			# If we have a mixed-case package name, assume case has been preserved
247			# correctly. Otherwise, root through the file to locate the case-preserved
248			# version of the package name.
249			if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
250			open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
251			my $in_pod = 0;
252			while ( <PKGFILE> ) {
253			$in_pod = 1 if /^=\w/;
254			$in_pod = 0 if /^=cut/;
255			next if ($in_pod \|\| /^=cut/); # skip pod text
256			next if /^\s*#/; # and comments
257			if ( m/^\spackage\s+($pkg)\s;/i ) {
258			$pkg = $1;
259			last;
260			}
261			}
262			close PKGFILE;
263			}
264
265			push @found, [ $file, $pkg ];
266			}, $path ) if -d $path;
267
268			@found;
269			}
270
271			sub _caller {
272			my $depth = 0;
273			my $call = caller($depth);
274			while ( $call eq __PACKAGE__ ) {
275			$depth++;
276			$call = caller($depth);
277			}
278			return $call;
279			}
280
281			1;