« back to all changes in this revision
Viewing changes to inc/Module/Install.pm
- browse files at revision 6
- compare with another revision
- download diff
- download tarball
- view history from revision 6
- Committer: Bazaar Package Importer
- Author(s): John Lightsey
- Date: 2007-11-20 20:56:00 UTC
- mfrom: (1.1.4 upstream)
- Revision ID: james.westby@ubuntu.com-20071120205600-lw0eukfw3z9nccec
Tags: 1.20-1
* New upstream release
* Remove build-depends-indep on libmodule-install-perl
* Update homepage link in debian/control
* Remove build-depends-indep on libmodule-install-perl
* Update homepage link in debian/control
- files added:
- t/17_toolbar.t
- files removed:
- inc
- inc/Module
- inc/Module/Install
- files modified:
- Changes
added
removed
inc/Module/Install.pm
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.67';
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/^\s*package\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;
Loggerhead is a web-based interface for Breezy
Version: 2.0.1