source: perl/modules/WordWrap/inc/Module/Install.pm @ 1375a6a

debianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 1375a6a was 1375a6a, checked in by Nelson Elhage <nelhage@mit.edu>, 12 years ago
Add a word-wrapping style to the repo and default build.
  • Property mode set to 100644
File size: 8.6 KB
Line 
1#line 1
2package 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
20BEGIN {
21        require 5.004;
22}
23use strict 'vars';
24
25use vars qw{$VERSION};
26BEGIN {
27        # All Module::Install core packages now require synchronised versions.
28        # This will be used to ensure we don't accidentally load old or
29        # different versions of modules.
30        # This is not enforced yet, but will be some time in the next few
31        # releases once we can make sure it won't clash with custom
32        # Module::Install extensions.
33        $VERSION = '0.79';
34
35        *inc::Module::Install::VERSION = *VERSION;
36        @inc::Module::Install::ISA     = __PACKAGE__;
37
38}
39
40
41
42
43
44# Whether or not inc::Module::Install is actually loaded, the
45# $INC{inc/Module/Install.pm} is what will still get set as long as
46# the caller loaded module this in the documented manner.
47# If not set, the caller may NOT have loaded the bundled version, and thus
48# they may not have a MI version that works with the Makefile.PL. This would
49# result in false errors or unexpected behaviour. And we don't want that.
50my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
51unless ( $INC{$file} ) { die <<"END_DIE" }
52
53Please invoke ${\__PACKAGE__} with:
54
55        use inc::${\__PACKAGE__};
56
57not:
58
59        use ${\__PACKAGE__};
60
61END_DIE
62
63
64
65
66
67# If the script that is loading Module::Install is from the future,
68# then make will detect this and cause it to re-run over and over
69# again. This is bad. Rather than taking action to touch it (which
70# is unreliable on some platforms and requires write permissions)
71# for now we should catch this and refuse to run.
72if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
73
74Your installer $0 has a modification time in the future.
75
76This is known to create infinite loops in make.
77
78Please correct this, then run $0 again.
79
80END_DIE
81
82
83
84
85
86# Build.PL was formerly supported, but no longer is due to excessive
87# difficulty in implementing every single feature twice.
88if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
89
90Module::Install no longer supports Build.PL.
91
92It was impossible to maintain duel backends, and has been deprecated.
93
94Please remove all Build.PL files and only use the Makefile.PL installer.
95
96END_DIE
97
98
99
100
101
102# To save some more typing in Module::Install installers, every...
103# use inc::Module::Install
104# ...also acts as an implicit use strict.
105$^H |= strict::bits(qw(refs subs vars));
106
107
108
109
110
111use Cwd        ();
112use File::Find ();
113use File::Path ();
114use FindBin;
115
116sub autoload {
117        my $self = shift;
118        my $who  = $self->_caller;
119        my $cwd  = Cwd::cwd();
120        my $sym  = "${who}::AUTOLOAD";
121        $sym->{$cwd} = sub {
122                my $pwd = Cwd::cwd();
123                if ( my $code = $sym->{$pwd} ) {
124                        # delegate back to parent dirs
125                        goto &$code unless $cwd eq $pwd;
126                }
127                $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
128                unless ( uc($1) eq $1 ) {
129                        unshift @_, ( $self, $1 );
130                        goto &{$self->can('call')};
131                }
132        };
133}
134
135sub import {
136        my $class = shift;
137        my $self  = $class->new(@_);
138        my $who   = $self->_caller;
139
140        unless ( -f $self->{file} ) {
141                require "$self->{path}/$self->{dispatch}.pm";
142                File::Path::mkpath("$self->{prefix}/$self->{author}");
143                $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
144                $self->{admin}->init;
145                @_ = ($class, _self => $self);
146                goto &{"$self->{name}::import"};
147        }
148
149        *{"${who}::AUTOLOAD"} = $self->autoload;
150        $self->preload;
151
152        # Unregister loader and worker packages so subdirs can use them again
153        delete $INC{"$self->{file}"};
154        delete $INC{"$self->{path}.pm"};
155
156        return 1;
157}
158
159sub preload {
160        my $self = shift;
161        unless ( $self->{extensions} ) {
162                $self->load_extensions(
163                        "$self->{prefix}/$self->{path}", $self
164                );
165        }
166
167        my @exts = @{$self->{extensions}};
168        unless ( @exts ) {
169                my $admin = $self->{admin};
170                @exts = $admin->load_all_extensions;
171        }
172
173        my %seen;
174        foreach my $obj ( @exts ) {
175                while (my ($method, $glob) = each %{ref($obj) . '::'}) {
176                        next unless $obj->can($method);
177                        next if $method =~ /^_/;
178                        next if $method eq uc($method);
179                        $seen{$method}++;
180                }
181        }
182
183        my $who = $self->_caller;
184        foreach my $name ( sort keys %seen ) {
185                *{"${who}::$name"} = sub {
186                        ${"${who}::AUTOLOAD"} = "${who}::$name";
187                        goto &{"${who}::AUTOLOAD"};
188                };
189        }
190}
191
192sub new {
193        my ($class, %args) = @_;
194
195        # ignore the prefix on extension modules built from top level.
196        my $base_path = Cwd::abs_path($FindBin::Bin);
197        unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
198                delete $args{prefix};
199        }
200
201        return $args{_self} if $args{_self};
202
203        $args{dispatch} ||= 'Admin';
204        $args{prefix}   ||= 'inc';
205        $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
206        $args{bundle}   ||= 'inc/BUNDLES';
207        $args{base}     ||= $base_path;
208        $class =~ s/^\Q$args{prefix}\E:://;
209        $args{name}     ||= $class;
210        $args{version}  ||= $class->VERSION;
211        unless ( $args{path} ) {
212                $args{path}  = $args{name};
213                $args{path}  =~ s!::!/!g;
214        }
215        $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
216        $args{wrote}      = 0;
217
218        bless( \%args, $class );
219}
220
221sub call {
222        my ($self, $method) = @_;
223        my $obj = $self->load($method) or return;
224        splice(@_, 0, 2, $obj);
225        goto &{$obj->can($method)};
226}
227
228sub load {
229        my ($self, $method) = @_;
230
231        $self->load_extensions(
232                "$self->{prefix}/$self->{path}", $self
233        ) unless $self->{extensions};
234
235        foreach my $obj (@{$self->{extensions}}) {
236                return $obj if $obj->can($method);
237        }
238
239        my $admin = $self->{admin} or die <<"END_DIE";
240The '$method' method does not exist in the '$self->{prefix}' path!
241Please remove the '$self->{prefix}' directory and run $0 again to load it.
242END_DIE
243
244        my $obj = $admin->load($method, 1);
245        push @{$self->{extensions}}, $obj;
246
247        $obj;
248}
249
250sub load_extensions {
251        my ($self, $path, $top) = @_;
252
253        unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
254                unshift @INC, $self->{prefix};
255        }
256
257        foreach my $rv ( $self->find_extensions($path) ) {
258                my ($file, $pkg) = @{$rv};
259                next if $self->{pathnames}{$pkg};
260
261                local $@;
262                my $new = eval { require $file; $pkg->can('new') };
263                unless ( $new ) {
264                        warn $@ if $@;
265                        next;
266                }
267                $self->{pathnames}{$pkg} = delete $INC{$file};
268                push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
269        }
270
271        $self->{extensions} ||= [];
272}
273
274sub find_extensions {
275        my ($self, $path) = @_;
276
277        my @found;
278        File::Find::find( sub {
279                my $file = $File::Find::name;
280                return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
281                my $subpath = $1;
282                return if lc($subpath) eq lc($self->{dispatch});
283
284                $file = "$self->{path}/$subpath.pm";
285                my $pkg = "$self->{name}::$subpath";
286                $pkg =~ s!/!::!g;
287
288                # If we have a mixed-case package name, assume case has been preserved
289                # correctly.  Otherwise, root through the file to locate the case-preserved
290                # version of the package name.
291                if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
292                        my $content = Module::Install::_read($subpath . '.pm');
293                        my $in_pod  = 0;
294                        foreach ( split //, $content ) {
295                                $in_pod = 1 if /^=\w/;
296                                $in_pod = 0 if /^=cut/;
297                                next if ($in_pod || /^=cut/);  # skip pod text
298                                next if /^\s*#/;               # and comments
299                                if ( m/^\s*package\s+($pkg)\s*;/i ) {
300                                        $pkg = $1;
301                                        last;
302                                }
303                        }
304                }
305
306                push @found, [ $file, $pkg ];
307        }, $path ) if -d $path;
308
309        @found;
310}
311
312
313
314
315
316#####################################################################
317# Utility Functions
318
319sub _caller {
320        my $depth = 0;
321        my $call  = caller($depth);
322        while ( $call eq __PACKAGE__ ) {
323                $depth++;
324                $call = caller($depth);
325        }
326        return $call;
327}
328
329sub _read {
330        local *FH;
331        open FH, "< $_[0]" or die "open($_[0]): $!";
332        my $str = do { local $/; <FH> };
333        close FH or die "close($_[0]): $!";
334        return $str;
335}
336
337sub _write {
338        local *FH;
339        open FH, "> $_[0]" or die "open($_[0]): $!";
340        foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
341        close FH or die "close($_[0]): $!";
342}
343
344# _version is for processing module versions (eg, 1.03_05) not
345# Perl versions (eg, 5.8.1).
346
347sub _version ($) {
348        my $s = shift || 0;
349           $s =~ s/^(\d+)\.?//;
350        my $l = $1 || 0;
351        my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
352           $l = $l . '.' . join '', @v if @v;
353        return $l + 0;
354}
355
356# Cloned from Params::Util::_CLASS
357sub _CLASS ($) {
358        (
359                defined $_[0]
360                and
361                ! ref $_[0]
362                and
363                $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
364        ) ? $_[0] : undef;
365}
366
3671;
368
369# Copyright 2008 - 2009 Adam Kennedy.
Note: See TracBrowser for help on using the repository browser.