← Back to branch summary

~ubuntu-branches/ubuntu/vivid/libmonitoring-livestatus-class-perl/vivid-proposed

« back to all changes in this revision

Viewing changes to inc/Module/Install.pm

  • Committer: Package Import Robot
  • Author(s): Alexander Wirt
  • Date: 2012-09-23 12:52:44 UTC
  • Revision ID: package-import@ubuntu.com-20120923125244-tj2b60nma3530edj
Tags: upstream-0.3
Import upstream version 0.3

Show diffs side-by-side

added added

removed removed

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