source: perl/modules/Jabber/inc/Module/Install.pm @ 5073972

barnowl_perlaimdebianrelease-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since 5073972 was 300b470, checked in by Nelson Elhage <nelhage@mit.edu>, 15 years ago
Adding a Module::Install plugin for building barnowl plugins. It needs a lot of improvement.
  • Property mode set to 100644
File size: 7.9 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.004;
21use strict 'vars';
22
23use vars qw{$VERSION};
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.65';
32}
33
34# Whether or not inc::Module::Install is actually loaded, the
35# $INC{inc/Module/Install.pm} is what will still get set as long as
36# the caller loaded module this in the documented manner.
37# If not set, the caller may NOT have loaded the bundled version, and thus
38# they may not have a MI version that works with the Makefile.PL. This would
39# result in false errors or unexpected behaviour. And we don't want that.
40my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
41unless ( $INC{$file} ) {
42    die <<"END_DIE";
43Please invoke ${\__PACKAGE__} with:
44
45    use inc::${\__PACKAGE__};
46
47not:
48
49    use ${\__PACKAGE__};
50
51END_DIE
52}
53
54# If the script that is loading Module::Install is from the future,
55# then make will detect this and cause it to re-run over and over
56# again. This is bad. Rather than taking action to touch it (which
57# is unreliable on some platforms and requires write permissions)
58# for now we should catch this and refuse to run.
59if ( -f $0 and (stat($0))[9] > time ) {
60        die << "END_DIE";
61Your installer $0 has a modification time in the future.
62
63This is known to create infinite loops in make.
64
65Please correct this, then run $0 again.
66
67END_DIE
68}
69
70use Cwd        ();
71use File::Find ();
72use File::Path ();
73use FindBin;
74
75*inc::Module::Install::VERSION = *VERSION;
76@inc::Module::Install::ISA     = __PACKAGE__;
77
78sub 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    };
93}
94
95sub 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"};
115}
116
117sub 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    }
149}
150
151sub 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 );
177}
178
179sub call {
180        my ($self, $method) = @_;
181        my $obj = $self->load($method) or return;
182        splice(@_, 0, 2, $obj);
183        goto &{$obj->can($method)};
184}
185
186sub 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";
198The '$method' method does not exist in the '$self->{prefix}' path!
199Please remove the '$self->{prefix}' directory and run $0 again to load it.
200END_DIE
201
202    my $obj = $admin->load($method, 1);
203    push @{$self->{extensions}}, $obj;
204
205    $obj;
206}
207
208sub 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} ||= [];
230}
231
232sub 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;
269}
270
271sub _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;
279}
280
2811;
Note: See TracBrowser for help on using the repository browser.