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.61';
}

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

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 exists &{ref($obj).'::'.$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.61';
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			use Cwd ();
55			use File::Find ();
56			use File::Path ();
57			use FindBin;
58
59			inc::Module::Install::VERSION = VERSION;
60			@inc::Module::Install::ISA = __PACKAGE__;
61
62			sub autoload {
63			my $self = shift;
64			my $who = $self->_caller;
65			my $cwd = Cwd::cwd();
66			my $sym = "${who}::AUTOLOAD";
67			$sym->{$cwd} = sub {
68			my $pwd = Cwd::cwd();
69			if ( my $code = $sym->{$pwd} ) {
70			# delegate back to parent dirs
71			goto &$code unless $cwd eq $pwd;
72			}
73			$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
74			unshift @_, ($self, $1);
75			goto &{$self->can('call')} unless uc($1) eq $1;
76			};
77			}
78
79			sub import {
80			my $class = shift;
81			my $self = $class->new(@_);
82			my $who = $self->_caller;
83
84			unless ( -f $self->{file} ) {
85			require "$self->{path}/$self->{dispatch}.pm";
86			File::Path::mkpath("$self->{prefix}/$self->{author}");
87			$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
88			$self->{admin}->init;
89			@_ = ($class, _self => $self);
90			goto &{"$self->{name}::import"};
91			}
92
93			*{"${who}::AUTOLOAD"} = $self->autoload;
94			$self->preload;
95
96			# Unregister loader and worker packages so subdirs can use them again
97			delete $INC{"$self->{file}"};
98			delete $INC{"$self->{path}.pm"};
99			}
100
101			sub preload {
102			my ($self) = @_;
103
104			unless ( $self->{extensions} ) {
105			$self->load_extensions(
106			"$self->{prefix}/$self->{path}", $self
107			);
108			}
109
110			my @exts = @{$self->{extensions}};
111			unless ( @exts ) {
112			my $admin = $self->{admin};
113			@exts = $admin->load_all_extensions;
114			}
115
116			my %seen;
117			foreach my $obj ( @exts ) {
118			while (my ($method, $glob) = each %{ref($obj) . '::'}) {
119			next unless exists &{ref($obj).'::'.$method};
120			next if $method =~ /^_/;
121			next if $method eq uc($method);
122			$seen{$method}++;
123			}
124			}
125
126			my $who = $self->_caller;
127			foreach my $name ( sort keys %seen ) {
128			*{"${who}::$name"} = sub {
129			${"${who}::AUTOLOAD"} = "${who}::$name";
130			goto &{"${who}::AUTOLOAD"};
131			};
132			}
133			}
134
135			sub new {
136			my ($class, %args) = @_;
137
138			# ignore the prefix on extension modules built from top level.
139			my $base_path = Cwd::abs_path($FindBin::Bin);
140			unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
141			delete $args{prefix};
142			}
143
144			return $args{_self} if $args{_self};
145
146			$args{dispatch} \|\|= 'Admin';
147			$args{prefix} \|\|= 'inc';
148			$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
149			$args{bundle} \|\|= 'inc/BUNDLES';
150			$args{base} \|\|= $base_path;
151			$class =~ s/^\Q$args{prefix}\E:://;
152			$args{name} \|\|= $class;
153			$args{version} \|\|= $class->VERSION;
154			unless ( $args{path} ) {
155			$args{path} = $args{name};
156			$args{path} =~ s!::!/!g;
157			}
158			$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
159
160			bless( \%args, $class );
161			}
162
163			sub call {
164			my ($self, $method) = @_;
165			my $obj = $self->load($method) or return;
166			splice(@_, 0, 2, $obj);
167			goto &{$obj->can($method)};
168			}
169
170			sub load {
171			my ($self, $method) = @_;
172
173			$self->load_extensions(
174			"$self->{prefix}/$self->{path}", $self
175			) unless $self->{extensions};
176
177			foreach my $obj (@{$self->{extensions}}) {
178			return $obj if $obj->can($method);
179			}
180
181			my $admin = $self->{admin} or die <<"END_DIE";
182			The '$method' method does not exist in the '$self->{prefix}' path!
183			Please remove the '$self->{prefix}' directory and run $0 again to load it.
184			END_DIE
185
186			my $obj = $admin->load($method, 1);
187			push @{$self->{extensions}}, $obj;
188
189			$obj;
190			}
191
192			sub load_extensions {
193			my ($self, $path, $top) = @_;
194
195			unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
196			unshift @INC, $self->{prefix};
197			}
198
199			foreach my $rv ( $self->find_extensions($path) ) {
200			my ($file, $pkg) = @{$rv};
201			next if $self->{pathnames}{$pkg};
202
203			local $@;
204			my $new = eval { require $file; $pkg->can('new') };
205			unless ( $new ) {
206			warn $@ if $@;
207			next;
208			}
209			$self->{pathnames}{$pkg} = delete $INC{$file};
210			push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
211			}
212
213			$self->{extensions} \|\|= [];
214			}
215
216			sub find_extensions {
217			my ($self, $path) = @_;
218
219			my @found;
220			File::Find::find( sub {
221			my $file = $File::Find::name;
222			return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
223			my $subpath = $1;
224			return if lc($subpath) eq lc($self->{dispatch});
225
226			$file = "$self->{path}/$subpath.pm";
227			my $pkg = "$self->{name}::$subpath";
228			$pkg =~ s!/!::!g;
229
230			# If we have a mixed-case package name, assume case has been preserved
231			# correctly. Otherwise, root through the file to locate the case-preserved
232			# version of the package name.
233			if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
234			open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
235			my $in_pod = 0;
236			while ( <PKGFILE> ) {
237			$in_pod = 1 if /^=\w/;
238			$in_pod = 0 if /^=cut/;
239			next if ($in_pod \|\| /^=cut/); # skip pod text
240			next if /^\s*#/; # and comments
241			if ( m/^\spackage\s+($pkg)\s;/i ) {
242			$pkg = $1;
243			last;
244			}
245			}
246			close PKGFILE;
247			}
248
249			push @found, [ $file, $pkg ];
250			}, $path ) if -d $path;
251
252			@found;
253			}
254
255			sub _caller {
256			my $depth = 0;
257			my $call = caller($depth);
258			while ( $call eq __PACKAGE__ ) {
259			$depth++;
260			$call = caller($depth);
261			}
262			return $call;
263			}
264
265			1;