Commit | Line | Data |
54123ee5 |
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/^\s*package\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; |