File Coverage

blib/lib/PAR/Heavy.pm
Criterion Covered Total %
statement 15 74 20.2
branch 4 56 7.1
condition 0 15 0.0
subroutine 1 5 20.0
pod n/a
total 20 150 13.3


line stmt bran cond sub pod time code
1             package PAR::Heavy;
2             $PAR::Heavy::VERSION = '0.12';
3              
4             =head1 NAME
5              
6             PAR::Heavy - PAR guts
7              
8             =head1 SYNOPSIS
9              
10             (internal use only)
11              
12             =head1 DESCRIPTION
13              
14             No user-serviceable parts inside.
15              
16             =cut
17              
18             ########################################################################
19             # Dynamic inclusion of XS modules
20              
21             # NOTE: Don't "use" any module here, esp. one that is an XS module or
22             # whose "use" could cause the loading of an XS module thru its dependencies.
23              
24             # enable debug/trace messages from DynaLoader perl code
25             my $dl_debug = $ENV{PERL_DL_DEBUG} || 0;
26              
27             my ($bootstrap, $dl_findfile); # Caches for code references
28             my ($cache_key); # The current file to find
29             my $is_insensitive_fs = (
30             -s $0
31             and (-s lc($0) || -1) == (-s uc($0) || -1)
32             and (-s lc($0) || -1) == -s $0
33             );
34              
35             # Adds pre-hooks to Dynaloader's key methods
36             sub _init_dynaloader {
37 7 100   7   26 return if $bootstrap;
38 4 50       18 return unless eval { require DynaLoader; DynaLoader::dl_findfile(); 1 };
  4         25  
  4         60  
  4         22  
39              
40 4 50       15 print STDERR "PAR::Heavy: pre-hooks to Dynaloader's key methods\n"
41             if $dl_debug;
42              
43 4         10 $bootstrap = \&DynaLoader::bootstrap;
44 4         16 $dl_findfile = \&DynaLoader::dl_findfile;
45              
46 4         31 local $^W;
47 4     0   18 *{'DynaLoader::dl_expandspec'} = sub { return };
  4         127  
  0         0  
48 4         16 *{'DynaLoader::bootstrap'} = \&_bootstrap;
  4         17  
49 4         9 *{'DynaLoader::dl_findfile'} = \&_dl_findfile;
  4         20  
50             }
51              
52             # Return the cached location of .dll inside PAR first, if possible.
53             sub _dl_findfile {
54 0 0   0     print STDERR "PAR::Heavy::_dl_findfile($cache_key)\n" if $dl_debug;
55              
56 0 0         if (exists $FullCache{$cache_key}) {
57 0 0         print STDERR " found in FullCache as $FullCache{$cache_key}\n"
58             if $dl_debug;
59 0           return $FullCache{$cache_key};
60             }
61 0 0         if ($is_insensitive_fs) {
62             # We have a case-insensitive filesystem...
63 0           my ($key) = grep { lc($_) eq lc($cache_key) } keys %FullCache;
  0            
64 0 0         if (defined $key) {
65 0 0         print STDERR " found case-insensitively in FullCache as $FullCache{$key}\n"
66             if $dl_debug;
67 0           return $FullCache{$key};
68             }
69             }
70 0 0         print STDERR " fall back to DynaLoader::dl_findfile\n" if $dl_debug;
71 0           return $dl_findfile->(@_);
72             }
73              
74             # Find and extract .dll from PAR files for a given dynamic module.
75             sub _bootstrap {
76 0     0     my (@args) = @_;
77 0 0         my ($module) = $args[0] or return;
78              
79 0           my @modparts = split(/::/, $module);
80 0           my $modfname = $modparts[-1];
81              
82 0 0         $modfname = &DynaLoader::mod2fname(\@modparts)
83             if defined &DynaLoader::mod2fname;
84              
85 0 0 0       if (($^O eq 'NetWare') && (length($modfname) > 8)) {
86 0           $modfname = substr($modfname, 0, 8);
87             }
88              
89 0 0         my $modpname = join((($^O eq 'MacOS') ? ':' : '/'), @modparts);
90 0           my $file = $cache_key = "auto/$modpname/$modfname.$DynaLoader::dl_dlext";
91              
92 0 0         if ($FullCache{$file}) {
93             # TODO: understand
94 0           local $DynaLoader::do_expand = 1;
95 0           return $bootstrap->(@args);
96             }
97              
98 0           my $member;
99             # First, try to find things in the preferentially loaded PARs:
100 0 0         $member = PAR::_find_par_internals([@PAR::PAR_INC], undef, $file, 1)
101             if defined &PAR::_find_par_internals;
102              
103             # If that failed to find the dll, let DynaLoader (try or) throw an error
104 0 0         unless ($member) {
105 0           my $filename = eval { $bootstrap->(@args) };
  0            
106 0 0 0       return $filename if not $@ and defined $filename;
107              
108             # Now try the fallback pars
109 0 0         $member = PAR::_find_par_internals([@PAR::PAR_INC_LAST], undef, $file, 1)
110             if defined &PAR::_find_par_internals;
111              
112             # If that fails, let dynaloader have another go JUST to throw an error
113             # While this may seem wasteful, nothing really matters once we fail to
114             # load shared libraries!
115 0 0         unless ($member) {
116 0           return $bootstrap->(@args);
117             }
118             }
119              
120 0           $FullCache{$file} = _dl_extract($member);
121              
122             # Now extract all associated shared objs in the same auto/ dir
123             # XXX: shouldn't this also set $FullCache{...} for those files?
124 0           my $first = $member->fileName;
125 0           my $path_pattern = $first;
126 0           $path_pattern =~ s{[^/]*$}{};
127 0 0         if ($PAR::LastAccessedPAR) {
128 0           foreach my $member ( $PAR::LastAccessedPAR->members ) {
129 0 0         next if $member->isDirectory;
130              
131 0           my $name = $member->fileName;
132 0 0         next if $name eq $first;
133 0 0         next unless $name =~ m{^/?\Q$path_pattern\E\/[^/]*\.\Q$DynaLoader::dl_dlext\E[^/]*$};
134 0           $name =~ s{.*/}{};
135 0           _dl_extract($member, $name);
136             }
137             }
138              
139 0           local $DynaLoader::do_expand = 1;
140 0           return $bootstrap->(@args);
141             }
142              
143             sub _dl_extract {
144 0     0     my ($member, $name) = @_;
145 0   0       $name ||= $member->crc32String . ".$DynaLoader::dl_dlext";
146              
147 0   0       my $filename = File::Spec->catfile($ENV{PAR_TEMP} || File::Spec->tmpdir, $name);
148 0           ($filename) = $filename =~ /^([\x20-\xff]+)$/;
149              
150 0 0 0       return $filename if -e $filename && -s _ == $member->uncompressedSize;
151              
152             # $filename doesn't exist or hasn't been completely extracted:
153             # extract it under a temporary name that isn't likely to be used
154             # by concurrent processes doing the same
155 0           my $tempname = "$filename.$$";
156 0 0         $member->extractToFileNamed($tempname) == Archive::Zip::AZ_OK()
157             or die "Can't extract archive member ".$member->fileName." to $tempname: $!";
158              
159             # now that we have a "good" copy in $tempname, rename it to $filename;
160             # if this fails (e.g. some OSes won't let you delete DLLs that are
161             # in use), but $filename exists, we assume that $filename is also
162             # "good": remove $tempname and return $filename
163 0 0         unless (rename($tempname, $filename))
164             {
165 0 0         -e $filename or die "can't rename $tempname to $filename: $!";
166 0           unlink($tempname);
167             }
168 0           return $filename;
169             }
170              
171             1;
172              
173             =head1 SEE ALSO
174              
175             L
176              
177             =head1 AUTHORS
178              
179             Audrey Tang Ecpan@audreyt.orgE
180              
181             You can write
182             to the mailing list at Epar@perl.orgE, or send an empty mail to
183             Epar-subscribe@perl.orgE to participate in the discussion.
184              
185             Please submit bug reports to Ebug-par@rt.cpan.orgE.
186              
187             =head1 COPYRIGHT
188              
189             Copyright 2002-2010 by Audrey Tang
190             Ecpan@audreyt.orgE.
191              
192             Copyright 2006-2010 by Steffen Mueller
193             Esmueller@cpan.orgE.
194              
195             This program is free software; you can redistribute it and/or modify it
196             under the same terms as Perl itself.
197              
198             See F.
199              
200             =cut