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