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