← Back to branch summary

~titusx/nginx/module-substitutions

« back to all changes in this revision

Viewing changes to test/inc/Module/Install.pm

  • Committer: Weibin Yao
  • Date: 2010-08-11 08:36:05 UTC
  • mfrom: (10.1.19)
  • Revision ID: git-v1:69c4c8dfe2c82aeabf8d6c5736b134c7dadaeb73
merge from the develop branch, r37


git-svn-id: http://substitutions4nginx.googlecode.com/svn/trunk@38 184bbb60-1f5e-11de-b650-e715bd6d7cf1

Show diffs side-by-side

added added

removed removed

Lines of Context:
test/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.005;
 
21
use strict 'vars';
 
22
 
 
23
use vars qw{$VERSION $MAIN};
 
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.91';
 
32
 
 
33
        # Storage for the pseudo-singleton
 
34
        $MAIN    = undef;
 
35
 
 
36
        *inc::Module::Install::VERSION = *VERSION;
 
37
        @inc::Module::Install::ISA     = __PACKAGE__;
 
38
 
 
39
}
 
40
 
 
41
 
 
42
 
 
43
 
 
44
 
 
45
# Whether or not inc::Module::Install is actually loaded, the
 
46
# $INC{inc/Module/Install.pm} is what will still get set as long as
 
47
# the caller loaded module this in the documented manner.
 
48
# If not set, the caller may NOT have loaded the bundled version, and thus
 
49
# they may not have a MI version that works with the Makefile.PL. This would
 
50
# result in false errors or unexpected behaviour. And we don't want that.
 
51
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
 
52
unless ( $INC{$file} ) { die <<"END_DIE" }
 
53
 
 
54
Please invoke ${\__PACKAGE__} with:
 
55
 
 
56
        use inc::${\__PACKAGE__};
 
57
 
 
58
not:
 
59
 
 
60
        use ${\__PACKAGE__};
 
61
 
 
62
END_DIE
 
63
 
 
64
 
 
65
 
 
66
 
 
67
 
 
68
# If the script that is loading Module::Install is from the future,
 
69
# then make will detect this and cause it to re-run over and over
 
70
# again. This is bad. Rather than taking action to touch it (which
 
71
# is unreliable on some platforms and requires write permissions)
 
72
# for now we should catch this and refuse to run.
 
73
if ( -f $0 ) {
 
74
        my $s = (stat($0))[9];
 
75
 
 
76
        # If the modification time is only slightly in the future,
 
77
        # sleep briefly to remove the problem.
 
78
        my $a = $s - time;
 
79
        if ( $a > 0 and $a < 5 ) { sleep 5 }
 
80
 
 
81
        # Too far in the future, throw an error.
 
82
        my $t = time;
 
83
        if ( $s > $t ) { die <<"END_DIE" }
 
84
 
 
85
Your installer $0 has a modification time in the future ($s > $t).
 
86
 
 
87
This is known to create infinite loops in make.
 
88
 
 
89
Please correct this, then run $0 again.
 
90
 
 
91
END_DIE
 
92
}
 
93
 
 
94
 
 
95
 
 
96
 
 
97
 
 
98
# Build.PL was formerly supported, but no longer is due to excessive
 
99
# difficulty in implementing every single feature twice.
 
100
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
 
101
 
 
102
Module::Install no longer supports Build.PL.
 
103
 
 
104
It was impossible to maintain duel backends, and has been deprecated.
 
105
 
 
106
Please remove all Build.PL files and only use the Makefile.PL installer.
 
107
 
 
108
END_DIE
 
109
 
 
110
 
 
111
 
 
112
 
 
113
 
 
114
# To save some more typing in Module::Install installers, every...
 
115
# use inc::Module::Install
 
116
# ...also acts as an implicit use strict.
 
117
$^H |= strict::bits(qw(refs subs vars));
 
118
 
 
119
 
 
120
 
 
121
 
 
122
 
 
123
use Cwd        ();
 
124
use File::Find ();
 
125
use File::Path ();
 
126
use FindBin;
 
127
 
 
128
sub autoload {
 
129
        my $self = shift;
 
130
        my $who  = $self->_caller;
 
131
        my $cwd  = Cwd::cwd();
 
132
        my $sym  = "${who}::AUTOLOAD";
 
133
        $sym->{$cwd} = sub {
 
134
                my $pwd = Cwd::cwd();
 
135
                if ( my $code = $sym->{$pwd} ) {
 
136
                        # Delegate back to parent dirs
 
137
                        goto &$code unless $cwd eq $pwd;
 
138
                }
 
139
                $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
 
140
                my $method = $1;
 
141
                if ( uc($method) eq $method ) {
 
142
                        # Do nothing
 
143
                        return;
 
144
                } elsif ( $method =~ /^_/ and $self->can($method) ) {
 
145
                        # Dispatch to the root M:I class
 
146
                        return $self->$method(@_);
 
147
                }
 
148
 
 
149
                # Dispatch to the appropriate plugin
 
150
                unshift @_, ( $self, $1 );
 
151
                goto &{$self->can('call')};
 
152
        };
 
153
}
 
154
 
 
155
sub import {
 
156
        my $class = shift;
 
157
        my $self  = $class->new(@_);
 
158
        my $who   = $self->_caller;
 
159
 
 
160
        unless ( -f $self->{file} ) {
 
161
                require "$self->{path}/$self->{dispatch}.pm";
 
162
                File::Path::mkpath("$self->{prefix}/$self->{author}");
 
163
                $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
 
164
                $self->{admin}->init;
 
165
                @_ = ($class, _self => $self);
 
166
                goto &{"$self->{name}::import"};
 
167
        }
 
168
 
 
169
        *{"${who}::AUTOLOAD"} = $self->autoload;
 
170
        $self->preload;
 
171
 
 
172
        # Unregister loader and worker packages so subdirs can use them again
 
173
        delete $INC{"$self->{file}"};
 
174
        delete $INC{"$self->{path}.pm"};
 
175
 
 
176
        # Save to the singleton
 
177
        $MAIN = $self;
 
178
 
 
179
        return 1;
 
180
}
 
181
 
 
182
sub preload {
 
183
        my $self = shift;
 
184
        unless ( $self->{extensions} ) {
 
185
                $self->load_extensions(
 
186
                        "$self->{prefix}/$self->{path}", $self
 
187
                );
 
188
        }
 
189
 
 
190
        my @exts = @{$self->{extensions}};
 
191
        unless ( @exts ) {
 
192
                @exts = $self->{admin}->load_all_extensions;
 
193
        }
 
194
 
 
195
        my %seen;
 
196
        foreach my $obj ( @exts ) {
 
197
                while (my ($method, $glob) = each %{ref($obj) . '::'}) {
 
198
                        next unless $obj->can($method);
 
199
                        next if $method =~ /^_/;
 
200
                        next if $method eq uc($method);
 
201
                        $seen{$method}++;
 
202
                }
 
203
        }
 
204
 
 
205
        my $who = $self->_caller;
 
206
        foreach my $name ( sort keys %seen ) {
 
207
                *{"${who}::$name"} = sub {
 
208
                        ${"${who}::AUTOLOAD"} = "${who}::$name";
 
209
                        goto &{"${who}::AUTOLOAD"};
 
210
                };
 
211
        }
 
212
}
 
213
 
 
214
sub new {
 
215
        my ($class, %args) = @_;
 
216
 
 
217
        # ignore the prefix on extension modules built from top level.
 
218
        my $base_path = Cwd::abs_path($FindBin::Bin);
 
219
        unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
 
220
                delete $args{prefix};
 
221
        }
 
222
 
 
223
        return $args{_self} if $args{_self};
 
224
 
 
225
        $args{dispatch} ||= 'Admin';
 
226
        $args{prefix}   ||= 'inc';
 
227
        $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
 
228
        $args{bundle}   ||= 'inc/BUNDLES';
 
229
        $args{base}     ||= $base_path;
 
230
        $class =~ s/^\Q$args{prefix}\E:://;
 
231
        $args{name}     ||= $class;
 
232
        $args{version}  ||= $class->VERSION;
 
233
        unless ( $args{path} ) {
 
234
                $args{path}  = $args{name};
 
235
                $args{path}  =~ s!::!/!g;
 
236
        }
 
237
        $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
 
238
        $args{wrote}      = 0;
 
239
 
 
240
        bless( \%args, $class );
 
241
}
 
242
 
 
243
sub call {
 
244
        my ($self, $method) = @_;
 
245
        my $obj = $self->load($method) or return;
 
246
        splice(@_, 0, 2, $obj);
 
247
        goto &{$obj->can($method)};
 
248
}
 
249
 
 
250
sub load {
 
251
        my ($self, $method) = @_;
 
252
 
 
253
        $self->load_extensions(
 
254
                "$self->{prefix}/$self->{path}", $self
 
255
        ) unless $self->{extensions};
 
256
 
 
257
        foreach my $obj (@{$self->{extensions}}) {
 
258
                return $obj if $obj->can($method);
 
259
        }
 
260
 
 
261
        my $admin = $self->{admin} or die <<"END_DIE";
 
262
The '$method' method does not exist in the '$self->{prefix}' path!
 
263
Please remove the '$self->{prefix}' directory and run $0 again to load it.
 
264
END_DIE
 
265
 
 
266
        my $obj = $admin->load($method, 1);
 
267
        push @{$self->{extensions}}, $obj;
 
268
 
 
269
        $obj;
 
270
}
 
271
 
 
272
sub load_extensions {
 
273
        my ($self, $path, $top) = @_;
 
274
 
 
275
        unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
 
276
                unshift @INC, $self->{prefix};
 
277
        }
 
278
 
 
279
        foreach my $rv ( $self->find_extensions($path) ) {
 
280
                my ($file, $pkg) = @{$rv};
 
281
                next if $self->{pathnames}{$pkg};
 
282
 
 
283
                local $@;
 
284
                my $new = eval { require $file; $pkg->can('new') };
 
285
                unless ( $new ) {
 
286
                        warn $@ if $@;
 
287
                        next;
 
288
                }
 
289
                $self->{pathnames}{$pkg} = delete $INC{$file};
 
290
                push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
 
291
        }
 
292
 
 
293
        $self->{extensions} ||= [];
 
294
}
 
295
 
 
296
sub find_extensions {
 
297
        my ($self, $path) = @_;
 
298
 
 
299
        my @found;
 
300
        File::Find::find( sub {
 
301
                my $file = $File::Find::name;
 
302
                return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
 
303
                my $subpath = $1;
 
304
                return if lc($subpath) eq lc($self->{dispatch});
 
305
 
 
306
                $file = "$self->{path}/$subpath.pm";
 
307
                my $pkg = "$self->{name}::$subpath";
 
308
                $pkg =~ s!/!::!g;
 
309
 
 
310
                # If we have a mixed-case package name, assume case has been preserved
 
311
                # correctly.  Otherwise, root through the file to locate the case-preserved
 
312
                # version of the package name.
 
313
                if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
 
314
                        my $content = Module::Install::_read($subpath . '.pm');
 
315
                        my $in_pod  = 0;
 
316
                        foreach ( split //, $content ) {
 
317
                                $in_pod = 1 if /^=\w/;
 
318
                                $in_pod = 0 if /^=cut/;
 
319
                                next if ($in_pod || /^=cut/);  # skip pod text
 
320
                                next if /^\s*#/;               # and comments
 
321
                                if ( m/^\s*package\s+($pkg)\s*;/i ) {
 
322
                                        $pkg = $1;
 
323
                                        last;
 
324
                                }
 
325
                        }
 
326
                }
 
327
 
 
328
                push @found, [ $file, $pkg ];
 
329
        }, $path ) if -d $path;
 
330
 
 
331
        @found;
 
332
}
 
333
 
 
334
 
 
335
 
 
336
 
 
337
 
 
338
#####################################################################
 
339
# Common Utility Functions
 
340
 
 
341
sub _caller {
 
342
        my $depth = 0;
 
343
        my $call  = caller($depth);
 
344
        while ( $call eq __PACKAGE__ ) {
 
345
                $depth++;
 
346
                $call = caller($depth);
 
347
        }
 
348
        return $call;
 
349
}
 
350
 
 
351
sub _read {
 
352
        local *FH;
 
353
        if ( $] >= 5.006 ) {
 
354
                open( FH, '<', $_[0] ) or die "open($_[0]): $!";
 
355
        } else {
 
356
                open( FH, "< $_[0]"  ) or die "open($_[0]): $!";
 
357
        }
 
358
        my $string = do { local $/; <FH> };
 
359
        close FH or die "close($_[0]): $!";
 
360
        return $string;
 
361
}
 
362
 
 
363
sub _readperl {
 
364
        my $string = Module::Install::_read($_[0]);
 
365
        $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
 
366
        $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
 
367
        $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
 
368
        return $string;
 
369
}
 
370
 
 
371
sub _readpod {
 
372
        my $string = Module::Install::_read($_[0]);
 
373
        $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
 
374
        return $string if $_[0] =~ /\.pod\z/;
 
375
        $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
 
376
        $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
 
377
        $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
 
378
        $string =~ s/^\n+//s;
 
379
        return $string;
 
380
}
 
381
 
 
382
sub _write {
 
383
        local *FH;
 
384
        if ( $] >= 5.006 ) {
 
385
                open( FH, '>', $_[0] ) or die "open($_[0]): $!";
 
386
        } else {
 
387
                open( FH, "> $_[0]"  ) or die "open($_[0]): $!";
 
388
        }
 
389
        foreach ( 1 .. $#_ ) {
 
390
                print FH $_[$_] or die "print($_[0]): $!";
 
391
        }
 
392
        close FH or die "close($_[0]): $!";
 
393
}
 
394
 
 
395
# _version is for processing module versions (eg, 1.03_05) not
 
396
# Perl versions (eg, 5.8.1).
 
397
sub _version ($) {
 
398
        my $s = shift || 0;
 
399
        my $d =()= $s =~ /(\.)/g;
 
400
        if ( $d >= 2 ) {
 
401
                # Normalise multipart versions
 
402
                $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
 
403
        }
 
404
        $s =~ s/^(\d+)\.?//;
 
405
        my $l = $1 || 0;
 
406
        my @v = map {
 
407
                $_ . '0' x (3 - length $_)
 
408
        } $s =~ /(\d{1,3})\D?/g;
 
409
        $l = $l . '.' . join '', @v if @v;
 
410
        return $l + 0;
 
411
}
 
412
 
 
413
sub _cmp ($$) {
 
414
        _version($_[0]) <=> _version($_[1]);
 
415
}
 
416
 
 
417
# Cloned from Params::Util::_CLASS
 
418
sub _CLASS ($) {
 
419
        (
 
420
                defined $_[0]
 
421
                and
 
422
                ! ref $_[0]
 
423
                and
 
424
                $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
 
425
        ) ? $_[0] : undef;
 
426
}
 
427
 
 
428
1;
 
429
 
 
430
# Copyright 2008 - 2009 Adam Kennedy.