source: ocsinventory-agent/trunk/fuentes/inc/Module/Install.pm @ 468

Last change on this file since 468 was 468, checked in by mabarracus, 4 years ago

Copyt trusty code

File size: 10.1 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
20use 5.005;
21use strict 'vars';
22
23use vars qw{$VERSION $MAIN};
24BEGIN {
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.
51my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
52unless ( $INC{$file} ) { die <<"END_DIE" }
53
54Please invoke ${\__PACKAGE__} with:
55
56        use inc::${\__PACKAGE__};
57
58not:
59
60        use ${\__PACKAGE__};
61
62END_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.
73if ( -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
85Your installer $0 has a modification time in the future ($s > $t).
86
87This is known to create infinite loops in make.
88
89Please correct this, then run $0 again.
90
91END_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.
100if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
101
102Module::Install no longer supports Build.PL.
103
104It was impossible to maintain duel backends, and has been deprecated.
105
106Please remove all Build.PL files and only use the Makefile.PL installer.
107
108END_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
123use Cwd        ();
124use File::Find ();
125use File::Path ();
126use FindBin;
127
128sub 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
155sub 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
182sub 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
214sub 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
243sub 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
250sub 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";
262The '$method' method does not exist in the '$self->{prefix}' path!
263Please remove the '$self->{prefix}' directory and run $0 again to load it.
264END_DIE
265
266        my $obj = $admin->load($method, 1);
267        push @{$self->{extensions}}, $obj;
268
269        $obj;
270}
271
272sub 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
296sub 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
341sub _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
351sub _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
363sub _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
371sub _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
382sub _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).
397sub _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
413sub _cmp ($$) {
414        _version($_[0]) <=> _version($_[1]);
415}
416
417# Cloned from Params::Util::_CLASS
418sub _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
4281;
429
430# Copyright 2008 - 2009 Adam Kennedy.
Note: See TracBrowser for help on using the repository browser.