home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Heavy.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  3.6 KB  |  144 lines
  1. # $File: //member/autrijus/PAR/lib/PAR/Heavy.pm $ $Author: joker $
  2. # $Revision: 1.2 $ $Change: 6209 $ $DateTime: 2003/05/31 12:34:59 $
  3.  
  4. package PAR::Heavy;
  5. $PAR::Heavy::VERSION = '0.05';
  6.  
  7. =head1 NAME
  8.  
  9. PAR::Heavy - PAR guts
  10.  
  11. =head1 SYNOPSIS
  12.  
  13. (internal use only)
  14.  
  15. =head1 DESCRIPTION
  16.  
  17. No user-serviceable parts inside.
  18.  
  19. =cut
  20.  
  21. ########################################################################
  22. # Dynamic inclusion of XS modules
  23.  
  24. my ($bootstrap, $dl_findfile);    # Caches for code references
  25. my ($dlext);            # Cache for $Config{dlext}
  26.  
  27. # Adds pre-hooks to Dynaloader's key methods
  28. sub _init_dynaloader {
  29.     return if $bootstrap;
  30.     return unless eval { require DynaLoader; DynaLoader::dl_findfile(); 1 };
  31.  
  32.     $bootstrap   = \&DynaLoader::bootstrap;
  33.     $dl_findfile = \&DynaLoader::dl_findfile;
  34.  
  35.     local $^W;
  36.     *{'DynaLoader::dl_expandspec'}  = sub { return };
  37.     *{'DynaLoader::bootstrap'}        = \&_bootstrap;
  38.     *{'DynaLoader::dl_findfile'}    = \&_dl_findfile;
  39. }
  40.  
  41. # Return the cached location of .dll inside PAR first, if possible.
  42. sub _dl_findfile {
  43.     return $DLCache{$_[-1]} if exists $DLCache{$_[-1]};
  44.     return $dl_findfile->(@_);
  45. }
  46.  
  47. # Find and extract .dll from PAR files for a given dynamic module.
  48. sub _bootstrap {
  49.     my (@args) = @_;
  50.     my ($module) = $args[0];
  51.     my (@dirs, $file);
  52.  
  53.     if ($module) {
  54.     my @modparts = split(/::/, $module);
  55.     my $modfname = $modparts[-1];
  56.  
  57.     $modfname = &DynaLoader::mod2fname(\@modparts)
  58.         if defined &DynaLoader::mod2fname;
  59.  
  60.     if (($^O eq 'NetWare') && (length($modfname) > 8)) {
  61.         $modfname = substr($modfname, 0, 8);
  62.     }
  63.  
  64.     # XXX: Multi-platform .dll support in PARs needs better than $Config.
  65.     $dlext ||= do { require Config; $Config::Config{dlext} };
  66.  
  67.     my $modpname = join((($^O eq 'MacOS') ? ':' : '/'), @modparts);
  68.     my $file = "auto/$modpname/$modfname.$dlext";
  69.  
  70.     if (!$DLCache{$file}++ and
  71.         defined &PAR::find_par and
  72.         my $member = PAR::find_par(undef, $file, 1)
  73.     ) {
  74.         require File::Spec;
  75.         require File::Temp;
  76.  
  77.         my ($fh, $filename);
  78.  
  79.         if ($ENV{PAR_CLEARTEMP}) {
  80.         ($fh, $filename) = File::Temp::tempfile(
  81.             DIR        => ($ENV{PAR_TEMP} || File::Spec->tmpdir),
  82.             SUFFIX    => ".$dlext",
  83.             UNLINK    => ($^O ne 'MSWin32'),
  84.         );
  85.         }
  86.         else {
  87.         $filename = File::Spec->catfile(
  88.             ($ENV{PAR_TEMP} || File::Spec->tmpdir),
  89.             $member->crc32String . ".$dlext"
  90.         );
  91.  
  92.         open $fh, '>', $filename or die $!
  93.             unless -r $filename and -s $file == $member->uncompressedSize;
  94.         }
  95.  
  96.         if ($fh) {
  97.         local $PAR::__reading = 1;
  98.         binmode($fh);
  99.         print $fh $member->contents;
  100.         close $fh;
  101.                 chmod 0755, $filename;
  102.         }
  103.  
  104.         $DLCache{$modfname} = $filename;
  105.         local $DynaLoader::do_expand = 1;
  106.         return $bootstrap->(@args);
  107.     }
  108.     elsif ($FullCache{$file}) {
  109.         $DLCache{$modfname} = $FullCache{$file};
  110.         local $DynaLoader::do_expand = 1;
  111.         return $bootstrap->(@args);
  112.     }
  113.     }
  114.  
  115.     $bootstrap->(@args);
  116. }
  117.  
  118. 1;
  119.  
  120. =head1 SEE ALSO
  121.  
  122. L<PAR>
  123.  
  124. =head1 AUTHORS
  125.  
  126. Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>
  127.  
  128. PAR has a mailing list, E<lt>par@perl.orgE<gt>, that you can write to;
  129. send an empty mail to E<lt>par-subscribe@perl.orgE<gt> to join the list
  130. and participate in the discussion.
  131.  
  132. Please send bug reports to E<lt>bug-par@rt.cpan.orgE<gt>.
  133.  
  134. =head1 COPYRIGHT
  135.  
  136. Copyright 2002, 2003 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>.
  137.  
  138. This program is free software; you can redistribute it and/or modify it
  139. under the same terms as Perl itself.
  140.  
  141. See L<http://www.perl.com/perl/misc/Artistic.html>
  142.  
  143. =cut
  144.