File Coverage

blib/lib/Module/Install/Admin.pm
Criterion Covered Total %
statement 42 125 33.6
branch 8 58 13.7
condition 1 24 4.1
subroutine 9 18 50.0
pod 0 8 0.0
total 60 233 25.7


line stmt bran cond sub pod time code
1             package Module::Install::Admin;
2              
3 3     3   26963 use strict 'vars';
  3         4  
  3         132  
4 3     3   13 use File::Path ();
  3         2  
  3         37  
5 3     3   1021 use inc::Module::Install ();
  3         3  
  3         61  
6              
7 3     3   14 use vars qw{$VERSION @ISA};
  3         3  
  3         152  
8             BEGIN {
9 3     3   14 $VERSION = '1.18';
10 3         480 @ISA = 'Module::Install';
11             }
12              
13             =pod
14              
15             =head1 NAME
16              
17             Module::Install::Admin - Author-side manager for Module::Install
18              
19             =head1 SYNOPSIS
20              
21             In a B extension module:
22              
23             sub extension_method {
24             my $self = shift;
25             $self->admin->some_method(@args);
26             }
27              
28             As an one-liner:
29              
30             % perl "-MModule::Install::Admin" -e'&some_method(@args);'
31              
32             The two snippets above are really shorthands for
33              
34             $some_obj->some_method(@args)
35              
36             where C<$some_obj> is the singleton object of a class under the
37             C namespace that provides the method
38             C. See L for a list of built-in methods.
39              
40             =head1 DESCRIPTION
41              
42             This module implements the internal mechanism for initializing,
43             including and managing extensions, and should only be of interest to
44             extension developers; it is I included under a distribution's
45             F directory, nor are any of the B
46             extensions.
47              
48             For normal usage of B, please see L
49             and L instead.
50              
51             =head2 Bootstrapping
52              
53             When someone runs a F that has C,
54             and there is no F in the current directory, B
55             will load this module bootstrap itself, through the steps below:
56              
57             =over 4
58              
59             =item *
60              
61             First, F is POD-stripped and copied from C<@INC> to
62             F. This should only happen on the author's side, never on the
63             end-user side.
64              
65             =item *
66              
67             Reload F if the current file is somewhere else.
68             This ensures that the included version of F is
69             always preferred over the installed version.
70              
71             =item *
72              
73             Look at F and load all of them.
74              
75             =item *
76              
77             Set up a C function to delegate missing function calls
78             to C -- again, this should only happen
79             at the author's side.
80              
81             =item *
82              
83             Provide a C function for removing included
84             files under F.
85              
86             =back
87              
88             =head1 METHODS
89              
90             =cut
91              
92             sub import {
93 2     2   14 my $class = shift;
94 2         8 my $self = $class->new( _top => Module::Install->new, @_ );
95 2         6 local $^W;
96 2         55 *{caller(0) . "::AUTOLOAD"} = sub {
97 3     3   11 no strict 'vars';
  3         4  
  3         3482  
98 0 0   0   0 $AUTOLOAD =~ /([^:]+)$/ or die "Cannot load";
99 0 0       0 return if uc($1) eq $1;
100 0 0       0 my $obj = $self->load($1) or return;
101 0         0 unshift @_, $obj;
102 0         0 goto &{$obj->can($1)};
  0         0  
103 2         7 };
104             }
105              
106             sub new {
107 2     2 0 5 my ($class, %args) = @_;
108             return $class->SUPER::new(
109 2         2 %{$args{_top}}, %args,
  2         22  
110             extensions => undef,
111             pathnames => undef,
112             );
113             }
114              
115             sub init {
116 0     0 0 0 my $self = shift;
117 0         0 $self->copy($INC{"$self->{path}.pm"} => $self->{file});
118              
119 0 0       0 unless ( grep { $_ eq $self->{prefix} } @INC ) {
  0         0  
120 0         0 unshift @INC, $self->{prefix};
121             }
122 0         0 delete $INC{"$self->{path}.pm"};
123              
124 0         0 local $^W;
125 0         0 do "$self->{path}.pm";
126             }
127              
128             sub copy {
129 1     1 0 4187 my ($self, $from, $to) = @_;
130              
131 1         3 my @parts = split('/', $to);
132 1 50       4 File::Path::mkpath([ join('/', @parts[ 0 .. $#parts-1 ])])
133             if @parts > 1;
134              
135 1         3 chomp $to;
136              
137 1         1 local ($_);
138 1 50       23 open my $FROM, "<", $from or die "Can't open $from for input:\n$!";
139 1 50       40 open my $TO, ">", $to or die "Can't open $to for output:\n$!";
140 1         2 binmode $FROM;
141 1         2 binmode $TO;
142 1         3 print $TO "#line 1\n";
143              
144 1         1 my $content;
145             my $in_pod;
146              
147 1         14 while ( <$FROM> ) {
148 3 50 33     15 if ( /^=(?:b(?:egin|ack)|head\d|(?:po|en)d|item|(?:ove|fo)r)/ ) {
    50          
    50          
149 0         0 $in_pod = 1;
150             } elsif ( /^=cut\s*\z/ and $in_pod ) {
151 0         0 $in_pod = 0;
152 0         0 print $TO "#line $.\n";
153             } elsif ( ! $in_pod ) {
154 3         7 print $TO $_;
155             }
156             }
157              
158 1 50       6 close $FROM or die "Can't close $from for input:\n$!";
159 1 50       20 close $TO or die "Can't close $to for output:\n$!";
160              
161 1         341 print "include $to\n";
162             }
163              
164             # scan through our target to find
165             sub load_all_extensions {
166 0     0 0   my $self = shift;
167 0 0         unless ($self->{extensions}) {
168 0           $self->{extensions} = [];
169 0           foreach my $inc (@INC) {
170 0 0 0       next if ref($inc) or $inc eq $self->{prefix};
171 0           $self->load_extensions("$inc/$self->{path}", $self->{_top});
172             }
173             }
174 0           return @{$self->{extensions}};
  0            
175             }
176              
177             sub load {
178 0     0 0   my ($self, $method, $copy) = @_;
179              
180 0           my @extobj;
181 0           foreach my $obj ($self->load_all_extensions) {
182 0 0         next unless defined &{ref($obj)."::$method"};
  0            
183 0           my $is_admin = (ref($obj) =~ /^\Q$self->{name}::$self->{dispatch}::/);
184             # Don't ever include admin modules, and vice versa.
185             # $copy = 0 if $XXX and $is_admin;
186 0 0 0       push @extobj, $obj if $copy xor $is_admin;
187             }
188 0 0         unless ( @extobj ) {
189 0           die "Cannot find an extension with method '$method'";
190             }
191              
192             # XXX - do we need to reload $obj from the new location?
193 0           my $obj = $self->pick($method, \@extobj);
194 0 0         $self->copy_package(ref($obj)) if $copy;
195              
196 0           return $obj;
197             }
198              
199             # Copy a package to inc/, with its @ISA tree. $pathname is optional.
200             sub copy_package {
201 0     0 0   my ($self, $pkg, $pathname) = @_;
202 0 0 0       return unless ($pathname ||= $self->{pathnames}{$pkg});
203              
204 0           my $file = $pkg; $file =~ s!::!/!g;
  0            
205 0           $file = "$self->{prefix}/$file.pm";
206 0 0         return if -f $file; # prevents infinite recursion
207              
208 0           $self->copy($pathname => $file);
209 0           foreach my $pkg (@{"$pkg\::ISA"}) {
  0            
210 0           $self->copy_package($pkg);
211             }
212             }
213              
214             sub pick {
215             # determine which name to load
216 0     0 0   my ($self, $method, $objects) = @_;
217              
218             # XXX this whole thing needs to be discussed
219 0 0 0       return $objects->[0] unless $#{$objects} > 0 and -t STDIN;
  0            
220              
221             # sort by last modified time
222 0           @$objects = map { $_->[0] }
223 0           sort { $a->[1] <=> $b->[1] }
224 0           map { [ $_ => -M $self->{pathnames}{ref($_)} ] } @$objects;
  0            
225              
226 0           print "Multiple extensions found for method '$method':\n";
227 0           foreach my $i ( 1 .. @$objects ) {
228 0           print "\t$i. ", ref($objects->[$i-1]), "\n";
229             }
230              
231 0           while ( 1 ) {
232 0           print "Please select one [1]: ";
233 0           chomp(my $choice = );
234 0   0       $choice ||= 1;
235 0 0 0       return $objects->[$choice-1] if $choice > 0 and $choice <= @$objects;
236 0           print "Invalid choice. ";
237             }
238             }
239              
240             sub delete_package {
241 0     0 0   my ($self, $pkg) = @_;
242              
243             # expand to full symbol table name if needed
244 0 0         unless ( $pkg =~ /^main::.*::$/ ) {
245 0 0         $pkg = "main$pkg" if $pkg =~ /^::/;
246 0 0         $pkg = "main::$pkg" unless $pkg =~ /^main::/;
247 0 0         $pkg .= '::' unless $pkg =~ /::$/;
248             }
249              
250 0           my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
251 0           my $stem_symtab = *{$stem}{HASH};
  0            
252 0 0 0       return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
253              
254             # free all the symbols in the package
255 0           my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
  0            
256 0           foreach my $name (keys %$leaf_symtab) {
257 0 0         next if $name eq "$self->{dispatch}::";
258 0           undef *{$pkg . $name};
  0            
259             }
260              
261             # delete the symbol table
262 0           foreach my $name (keys %$leaf_symtab) {
263 0 0         next if $name eq "$self->{dispatch}::";
264 0           delete $leaf_symtab->{$name};
265             }
266             }
267              
268             sub AUTOLOAD {
269 0     0     goto &{shift->autoload};
  0            
270             }
271              
272       0     sub DESTROY { }
273              
274             1;
275              
276             __END__