← Back to branch summary

~ubuntu-branches/ubuntu/vivid/libclass-accessor-grouped-perl/vivid

« back to all changes in this revision

Viewing changes to inc/Module/Install.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ansgar Burchardt, gregor herrmann, Ansgar Burchardt
  • Date: 2008-11-22 22:11:47 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20081122221147-svlt1hfw4sksn7qy
Tags: 0.08002-1
[ gregor herrmann ]
* debian/control: Changed: Switched Vcs-Browser field to ViewSVN
  (source stanza).

[ Ansgar Burchardt ]
* New upstream release.
* Convert debian/copyright to proposed machine-readable format.
* Refresh debian/rules for debhelper 7.
* Add myself to Uploaders.
* debian/control: Bump Standards-Version to 3.8.0 (no changes)

[ gregor herrmann ]
* debian/control: remove libmodule-install-perl from Build-Depends-Indep and
  wrap line.

Show diffs side-by-side

added added

removed removed

Lines of Context:
inc/Module/Install.pm
17
17
#     3. The ./inc/ version of Module::Install loads
18
18
# }
19
19
 
20
 
use 5.004;
 
20
BEGIN {
 
21
        require 5.004;
 
22
}
21
23
use strict 'vars';
22
24
 
23
25
use vars qw{$VERSION};
24
26
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.68';
 
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.77';
 
34
 
 
35
        *inc::Module::Install::VERSION = *VERSION;
 
36
        @inc::Module::Install::ISA     = __PACKAGE__;
 
37
 
32
38
}
33
39
 
 
40
 
 
41
 
 
42
 
 
43
 
34
44
# Whether or not inc::Module::Install is actually loaded, the
35
45
# $INC{inc/Module/Install.pm} is what will still get set as long as
36
46
# the caller loaded module this in the documented manner.
38
48
# they may not have a MI version that works with the Makefile.PL. This would
39
49
# result in false errors or unexpected behaviour. And we don't want that.
40
50
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
41
 
unless ( $INC{$file} ) {
42
 
    die <<"END_DIE";
 
51
unless ( $INC{$file} ) { die <<"END_DIE" }
 
52
 
43
53
Please invoke ${\__PACKAGE__} with:
44
54
 
45
 
    use inc::${\__PACKAGE__};
 
55
        use inc::${\__PACKAGE__};
46
56
 
47
57
not:
48
58
 
49
 
    use ${\__PACKAGE__};
 
59
        use ${\__PACKAGE__};
50
60
 
51
61
END_DIE
52
 
}
 
62
 
 
63
 
 
64
 
 
65
 
53
66
 
54
67
# If the script that is loading Module::Install is from the future,
55
68
# then make will detect this and cause it to re-run over and over
56
69
# again. This is bad. Rather than taking action to touch it (which
57
70
# is unreliable on some platforms and requires write permissions)
58
71
# for now we should catch this and refuse to run.
59
 
if ( -f $0 and (stat($0))[9] > time ) {
60
 
        die << "END_DIE";
 
72
if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
 
73
 
61
74
Your installer $0 has a modification time in the future.
62
75
 
63
76
This is known to create infinite loops in make.
65
78
Please correct this, then run $0 again.
66
79
 
67
80
END_DIE
68
 
}
 
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.
 
88
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
 
89
 
 
90
Module::Install no longer supports Build.PL.
 
91
 
 
92
It was impossible to maintain duel backends, and has been deprecated.
 
93
 
 
94
Please remove all Build.PL files and only use the Makefile.PL installer.
 
95
 
 
96
END_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
 
69
110
 
70
111
use Cwd        ();
71
112
use File::Find ();
72
113
use File::Path ();
73
114
use FindBin;
74
115
 
75
 
*inc::Module::Install::VERSION = *VERSION;
76
 
@inc::Module::Install::ISA     = __PACKAGE__;
77
 
 
78
116
sub autoload {
79
 
    my $self = shift;
80
 
    my $who  = $self->_caller;
81
 
    my $cwd  = Cwd::cwd();
82
 
    my $sym  = "${who}::AUTOLOAD";
83
 
    $sym->{$cwd} = sub {
84
 
        my $pwd = Cwd::cwd();
85
 
        if ( my $code = $sym->{$pwd} ) {
86
 
            # delegate back to parent dirs
87
 
            goto &$code unless $cwd eq $pwd;
88
 
        }
89
 
        $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
90
 
        unshift @_, ($self, $1);
91
 
        goto &{$self->can('call')} unless uc($1) eq $1;
92
 
    };
 
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
        };
93
133
}
94
134
 
95
135
sub import {
96
 
    my $class = shift;
97
 
    my $self  = $class->new(@_);
98
 
    my $who   = $self->_caller;
99
 
 
100
 
    unless ( -f $self->{file} ) {
101
 
        require "$self->{path}/$self->{dispatch}.pm";
102
 
        File::Path::mkpath("$self->{prefix}/$self->{author}");
103
 
        $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
104
 
        $self->{admin}->init;
105
 
        @_ = ($class, _self => $self);
106
 
        goto &{"$self->{name}::import"};
107
 
    }
108
 
 
109
 
    *{"${who}::AUTOLOAD"} = $self->autoload;
110
 
    $self->preload;
111
 
 
112
 
    # Unregister loader and worker packages so subdirs can use them again
113
 
    delete $INC{"$self->{file}"};
114
 
    delete $INC{"$self->{path}.pm"};
 
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;
115
157
}
116
158
 
117
159
sub preload {
118
 
    my ($self) = @_;
119
 
 
120
 
    unless ( $self->{extensions} ) {
121
 
        $self->load_extensions(
122
 
            "$self->{prefix}/$self->{path}", $self
123
 
        );
124
 
    }
125
 
 
126
 
    my @exts = @{$self->{extensions}};
127
 
    unless ( @exts ) {
128
 
        my $admin = $self->{admin};
129
 
        @exts = $admin->load_all_extensions;
130
 
    }
131
 
 
132
 
    my %seen;
133
 
    foreach my $obj ( @exts ) {
134
 
        while (my ($method, $glob) = each %{ref($obj) . '::'}) {
135
 
            next unless $obj->can($method);
136
 
            next if $method =~ /^_/;
137
 
            next if $method eq uc($method);
138
 
            $seen{$method}++;
139
 
        }
140
 
    }
141
 
 
142
 
    my $who = $self->_caller;
143
 
    foreach my $name ( sort keys %seen ) {
144
 
        *{"${who}::$name"} = sub {
145
 
            ${"${who}::AUTOLOAD"} = "${who}::$name";
146
 
            goto &{"${who}::AUTOLOAD"};
147
 
        };
148
 
    }
 
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
        }
149
190
}
150
191
 
151
192
sub new {
152
 
    my ($class, %args) = @_;
153
 
 
154
 
    # ignore the prefix on extension modules built from top level.
155
 
    my $base_path = Cwd::abs_path($FindBin::Bin);
156
 
    unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
157
 
        delete $args{prefix};
158
 
    }
159
 
 
160
 
    return $args{_self} if $args{_self};
161
 
 
162
 
    $args{dispatch} ||= 'Admin';
163
 
    $args{prefix}   ||= 'inc';
164
 
    $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
165
 
    $args{bundle}   ||= 'inc/BUNDLES';
166
 
    $args{base}     ||= $base_path;
167
 
    $class =~ s/^\Q$args{prefix}\E:://;
168
 
    $args{name}     ||= $class;
169
 
    $args{version}  ||= $class->VERSION;
170
 
    unless ( $args{path} ) {
171
 
        $args{path}  = $args{name};
172
 
        $args{path}  =~ s!::!/!g;
173
 
    }
174
 
    $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
175
 
 
176
 
    bless( \%args, $class );
 
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 );
177
219
}
178
220
 
179
221
sub call {
184
226
}
185
227
 
186
228
sub load {
187
 
    my ($self, $method) = @_;
188
 
 
189
 
    $self->load_extensions(
190
 
        "$self->{prefix}/$self->{path}", $self
191
 
    ) unless $self->{extensions};
192
 
 
193
 
    foreach my $obj (@{$self->{extensions}}) {
194
 
        return $obj if $obj->can($method);
195
 
    }
196
 
 
197
 
    my $admin = $self->{admin} or die <<"END_DIE";
 
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";
198
240
The '$method' method does not exist in the '$self->{prefix}' path!
199
241
Please remove the '$self->{prefix}' directory and run $0 again to load it.
200
242
END_DIE
201
243
 
202
 
    my $obj = $admin->load($method, 1);
203
 
    push @{$self->{extensions}}, $obj;
 
244
        my $obj = $admin->load($method, 1);
 
245
        push @{$self->{extensions}}, $obj;
204
246
 
205
 
    $obj;
 
247
        $obj;
206
248
}
207
249
 
208
250
sub load_extensions {
209
 
    my ($self, $path, $top) = @_;
210
 
 
211
 
    unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
212
 
        unshift @INC, $self->{prefix};
213
 
    }
214
 
 
215
 
    foreach my $rv ( $self->find_extensions($path) ) {
216
 
        my ($file, $pkg) = @{$rv};
217
 
        next if $self->{pathnames}{$pkg};
218
 
 
219
 
        local $@;
220
 
        my $new = eval { require $file; $pkg->can('new') };
221
 
        unless ( $new ) {
222
 
            warn $@ if $@;
223
 
            next;
224
 
        }
225
 
        $self->{pathnames}{$pkg} = delete $INC{$file};
226
 
        push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
227
 
    }
228
 
 
229
 
    $self->{extensions} ||= [];
 
251
        my ($self, $path, $top) = @_;
 
252
 
 
253
        unless ( grep { 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} ||= [];
230
272
}
231
273
 
232
274
sub find_extensions {
233
 
    my ($self, $path) = @_;
234
 
 
235
 
    my @found;
236
 
    File::Find::find( sub {
237
 
        my $file = $File::Find::name;
238
 
        return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
239
 
        my $subpath = $1;
240
 
        return if lc($subpath) eq lc($self->{dispatch});
241
 
 
242
 
        $file = "$self->{path}/$subpath.pm";
243
 
        my $pkg = "$self->{name}::$subpath";
244
 
        $pkg =~ s!/!::!g;
245
 
 
246
 
        # If we have a mixed-case package name, assume case has been preserved
247
 
        # correctly.  Otherwise, root through the file to locate the case-preserved
248
 
        # version of the package name.
249
 
        if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
250
 
            open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
251
 
            my $in_pod = 0;
252
 
            while ( <PKGFILE> ) {
253
 
                $in_pod = 1 if /^=\w/;
254
 
                $in_pod = 0 if /^=cut/;
255
 
                next if ($in_pod || /^=cut/);  # skip pod text
256
 
                next if /^\s*#/;               # and comments
257
 
                if ( m/^\s*package\s+($pkg)\s*;/i ) {
258
 
                    $pkg = $1;
259
 
                    last;
260
 
                }
261
 
            }
262
 
            close PKGFILE;
263
 
        }
264
 
 
265
 
        push @found, [ $file, $pkg ];
266
 
    }, $path ) if -d $path;
267
 
 
268
 
    @found;
 
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;
269
310
}
270
311
 
 
312
 
 
313
 
 
314
 
 
315
 
 
316
#####################################################################
 
317
# Utility Functions
 
318
 
271
319
sub _caller {
272
 
    my $depth = 0;
273
 
    my $call  = caller($depth);
274
 
    while ( $call eq __PACKAGE__ ) {
275
 
        $depth++;
276
 
        $call = caller($depth);
277
 
    }
278
 
    return $call;
 
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
 
 
329
sub _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
 
 
337
sub _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
 
 
347
sub _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
 
357
sub _CLASS ($) {
 
358
        (
 
359
                defined $_[0]
 
360
                and
 
361
                ! ref $_[0]
 
362
                and
 
363
                $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
 
364
        ) ? $_[0] : undef;
279
365
}
280
366
 
281
367
1;
 
368
 
 
369
# Copyright 2008 Adam Kennedy.