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 / FindPods.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  9.4 KB  |  400 lines
  1. # -*- perl -*-
  2.  
  3. #
  4. # $Id: FindPods.pm,v 1.2 2003/09/16 18:16:45 joker Exp $
  5. # Author: Slaven Rezic
  6. #
  7. # Copyright (C) 2001,2003 Slaven Rezic. All rights reserved.
  8. # This package is free software; you can redistribute it and/or
  9. # modify it under the same terms as Perl itself.
  10. #
  11. # Mail: slaven@rezic.de
  12. # WWW:  http://www.rezic.de/eserte/
  13. #
  14.  
  15. package Tk::Pod::FindPods;
  16.  
  17. =head1 NAME
  18.  
  19. Tk::Pod::FindPods - find Pods installed on the current system
  20.  
  21.  
  22. =head1 SYNOPSIS
  23.  
  24.     use Tk::Pod::FindPods;
  25.  
  26.     my $o = Tk::Pod::FindPods->new;
  27.     $pods = $o->pod_find(-categorized => 1, -usecache => 1);
  28.  
  29. =head1 DESCRIPTION
  30.  
  31. =cut
  32.  
  33. use base 'Exporter';
  34. use strict;
  35. use vars qw($VERSION @EXPORT_OK $init_done %arch $arch_re);
  36.  
  37. @EXPORT_OK = qw/%pods $has_cache pod_find/;
  38.  
  39. $VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
  40.  
  41. use File::Find;
  42. use File::Spec;
  43. use File::Basename;
  44. use Config;
  45.  
  46. sub new {
  47.     my($class) = @_;
  48.     my $self = bless {}, $class;
  49.     $self->init;
  50.     $self;
  51. }
  52.  
  53. sub init {
  54.     return if $init_done;
  55.     %arch = guess_architectures();
  56.     $arch_re = "(" . join("|", map { quotemeta $_ } ("mach", keys %arch)) . ")";
  57.     $init_done++;
  58. }
  59.  
  60. =head2 pod_find
  61.  
  62. The B<pod_find> method scans the current system for available Pod
  63. documentation. The keys of the returned hash reference are the names
  64. of the modules or Pods (C<::> substituted by C</> --- this makes it
  65. easier for Tk::Pod::Tree, as the separator may only be of one
  66. character). The values are the corresponding filenames.
  67.  
  68. If C<-categorized> is specified, then the returned hash has an extra
  69. level with four categories: B<perl> (for core language documentation),
  70. B<pragma> (for pragma documentation like L<var|var> or
  71. L<strict|strict>), B<mod> (core or CPAN modules), and B<script> (perl
  72. scripts with embedded Pod documentation). Otherwise, C<-category> may
  73. be set to force the Pods into a category.
  74.  
  75. If C<-usecache> is specified, then the list of Pods is cached in a
  76. temporary directory.
  77.  
  78. By default, C<@INC> is scanned for Pods. This can be overwritten by
  79. the C<-directories> option (specify as an array reference).
  80.  
  81. =cut
  82.  
  83. sub pod_find {
  84.     my $self = shift;
  85.     my(@args) = @_;
  86.     my %args;
  87.     if (ref $args[0] eq 'HASH') {
  88.     %args = %{ $args[0] };
  89.     } else {
  90.     %args = @args;
  91.     }
  92.  
  93.     $self->{has_cache} = 0;
  94.  
  95.     if ($args{-usecache}) {
  96.     my $perllocal_site = File::Spec->catfile($Config{'installsitearch'},'perllocal.pod');
  97.     my $perllocal_lib  = File::Spec->catfile($Config{'installarchlib'},'perllocal.pod');
  98.     my $cache_file = _cache_file();
  99.     if (!-r $cache_file ||
  100.         (-e $perllocal_site && -M $perllocal_site > -M $cache_file) ||
  101.         (-e $perllocal_lib  && -M $perllocal_lib > -M $cache_file)
  102.        ) {
  103.         $self->LoadCache;
  104.         if ($self->{pods}) {
  105.         $self->{has_cache} = 1;
  106.         return $self->{pods};
  107.         }
  108.     } else {
  109.         warn "$perllocal_site and/or $perllocal_lib are more recent than cache file $cache_file";
  110.     }
  111.     }
  112.  
  113.     my(@dirs, @script_dirs);
  114.     if ($args{-directories}) {
  115.     @dirs = @{ $args{-directories} };
  116.     @script_dirs = ();
  117.     } else {
  118.     @dirs = grep { $_ ne '.' } @INC; # ignore current directory
  119.     @script_dirs = ($Config{'scriptdir'});
  120.     }
  121.  
  122.     my %seen_dir = ();
  123.     my $curr_dir;
  124.     undef $curr_dir;
  125.     my %pods = ();
  126.  
  127.     if ($args{-category}) {
  128.     $pods{$args{-category}} = {};
  129.     }
  130.  
  131.     my $wanted = sub {
  132.     if (-d) {
  133.         if ($seen_dir{$File::Find::name}) {
  134.         $File::Find::prune = 1;
  135.         return;
  136.         } else {
  137.         $seen_dir{$File::Find::name}++;
  138.         }
  139.     }
  140.  
  141.     if (-f && /\.(pod|pm)$/) {
  142.         (my $name = $File::Find::name) =~ s|^$curr_dir/?||;
  143.         $name = simplify_name($name);
  144.  
  145.         my $hash;
  146.         if ($args{-categorized}) {
  147.         my $type = type($name);
  148.         $hash = $pods{$type} || do { $pods{$type} = {} };
  149.         } elsif ($args{-category}) {
  150.         $hash = $pods{$args{-category}};
  151.         } else {
  152.         $hash = \%pods;
  153.         }
  154.  
  155.         if (exists $hash->{$name}) {
  156.         if ($hash->{$name} =~ /\.pod$/ && $File::Find::name =~ /\.pm$/) {
  157.             return;
  158.         }
  159.         my($ext1) = $hash->{$name}    =~ /\.(.*)$/;
  160.         my($ext2) = $File::Find::name =~ /\.(.*)$/;
  161.         if ($ext1 eq $ext2) {
  162.             warn "Clash: $hash->{$name} <=> $File::Find::name";
  163.             return;
  164.         }
  165.         }
  166.         $hash->{$name} = "file:" . $File::Find::name;
  167.     }
  168.     };
  169.  
  170.     my $wanted_scripts = sub {
  171.     if (-d) {
  172.         if ($seen_dir{$File::Find::name}) {
  173.         $File::Find::prune = 1;
  174.         return;
  175.         } else {
  176.         $seen_dir{$File::Find::name}++;
  177.         }
  178.     }
  179.  
  180.     if (-T && open(SCRIPT, $_)) {
  181.         my $has_pod = 0;
  182.         {
  183.         local $_;
  184.         while(<SCRIPT>) {
  185.             if (/^=(head\d+|pod)/) {
  186.             $has_pod = 1;
  187.             last;
  188.             }
  189.         }
  190.         }
  191.         close SCRIPT;
  192.         if ($has_pod) {
  193.         my $name = $_;
  194.  
  195.         my $hash;
  196.         if ($args{-categorized}) {
  197.             my $type = 'script';
  198.             $hash = $pods{$type} || do { $pods{$type} = {} };
  199.         } elsif ($args{-category}) {
  200.             $hash = $pods{$args{-category}};
  201.         } else {
  202.             $hash = \%pods;
  203.         }
  204.  
  205.         if (exists $hash->{$name}) {
  206.             return;
  207.         }
  208.         $hash->{$name} = "file:" . $File::Find::name;
  209.         }
  210.     }
  211.     };
  212.  
  213.     foreach my $inc (@dirs) {
  214.     $curr_dir = $inc;
  215.     find($wanted, $inc);
  216.     }
  217.  
  218.     foreach my $inc (@script_dirs) {
  219.     find($wanted_scripts, $inc);
  220.     }
  221.  
  222.     #XXX
  223.     if ($args{-cpan}) {    $self->add_cpan }
  224.  
  225.     $self->{pods} = \%pods;
  226.     $self->{pods};
  227. }
  228.  
  229. # XXX nach .../CPAN.pm auslagern (MANIFEST & RCS nicht vergessen)
  230. sub add_cpan {
  231.     my $self = shift;
  232.     my $pods = $self->{pods};
  233.     require CPAN;
  234.     for my $mod (CPAN::Shell->expand("Module","/./")) {
  235.     next if $mod->inst_file;
  236.     next if $mod->cpan_file =~ /^Contact/;
  237.         # MakeMaker convention for undefined $VERSION:
  238. #    next unless $mod->inst_version eq "undef";
  239.     (my $path = $mod->id) =~ s|::|/|g;
  240.     do {warn "$path excluded..."; next} if $path =~ m|/$|; # XXX wrong name Audio::Play::, wait for mail from Andreas or Nick
  241.     # XXX -categorized???
  242.     $pods->{type($mod->id)}->{$path} = "cpan:" . $mod->id; # XXX k÷nnte OK sein
  243.     }
  244. }
  245.  
  246. sub simplify_name {
  247.     my $f = shift;
  248.     $f =~ s|^\d+\.\d+\.\d+/?||; # strip perl version
  249.     $f =~ s|^$arch_re|| if defined $arch_re; # strip machine
  250.     $f =~ s/\.(pod|pm)$//;
  251.     $f =~ s|^pod/||;
  252.     # Workaround for case insensitive systems --- the pod directory contains
  253.     # general pod documentation as well as Pod::* documentation:
  254.     if ($^O =~ /^cygwin/) {
  255.     $f =~ s|^pods/||; # "pod" is "pods" on cygwin
  256.     } elsif ($^O eq 'MSWin32') {
  257.     $f =~ s|^pod/perl|perl|i;
  258.     $f =~ s|^pod/Win32|Win32|i;
  259.     }
  260.     $f;
  261. }
  262.  
  263. sub type {
  264.     local $_ = shift;
  265.     if    (/^perl/) { return "perl" }
  266.     elsif (/^[a-z]/ && !/^(mod_perl|lwpcook|lwptut|cgi_to_mod_perl|libapreq)/)
  267.                 { return "pragma" }
  268.     else            { return "mod" }
  269. }
  270.  
  271. sub guess_architectures {
  272.     my %arch;
  273.     my @configs;
  274.     foreach my $inc (@INC) {
  275.     push @configs, glob("$inc/*/Config.pm");
  276.     }
  277.     foreach my $config (@configs) {
  278.     my($arch) = $config =~ m|/([^/]+)/Config.pm|;
  279.     if (open(CFG, $config)) {
  280.         while(<CFG>) {
  281.         /archname.*$arch/ && do {
  282.             $arch{$arch}++;
  283.             last;
  284.         };
  285.         }
  286.         close CFG;
  287.     } else {
  288.         warn "cannot open $config: $!";
  289.     }
  290.     }
  291.     %arch;
  292. }
  293.  
  294. sub module_location {
  295.     my $mod = shift;
  296.     my($type, $path) = $mod =~ /^([^:]+):(.*)/;
  297.     if ($type eq 'cpan') {
  298.     'cpan';
  299.     } elsif (is_site_module($path)) {
  300.     'site';
  301.     } else {
  302.     'core';
  303.     }
  304. }
  305.  
  306. sub is_site_module {
  307.     my $path = shift;
  308.     if ($^O eq 'MSWin32') {
  309.     return $path =~ m|[/\\]site[/\\]lib[/\\]|;
  310.     }
  311.     $path =~ /^(
  312.                 $Config{'installsitelib'}
  313.                |
  314.         $Config{'installsitearch'}
  315.            )/x;
  316. }
  317.  
  318. sub _cache_file {
  319.     (my $ver = $])                  =~ s/[^a-z0-9]/_/gi;
  320.     (my $os  = $Config{'archname'}) =~ s/[^a-z0-9]/_/gi;
  321.     my $uid  = $<;
  322.  
  323.     if (File::Spec->can('tmpdir')) {
  324.         File::Spec->catfile(File::Spec->tmpdir, join('_', 'pods',$ver,$os,$uid));
  325.       } else {
  326.         File::Spec->catfile(($ENV{TMPDIR}||"/tmp"), join('_', 'pods',$ver,$os,$uid));
  327.       }
  328. }
  329.  
  330. sub pods      { shift->{pods} }
  331. sub has_cache { shift->{has_cache} }
  332.  
  333. =head2 WriteCache
  334.  
  335. Write the Pod cache. The cache is written to the temporary directory.
  336. The file name is constructed from the perl version, operation system
  337. and user id.
  338.  
  339. =cut
  340.  
  341. sub WriteCache {
  342.     my $self = shift;
  343.  
  344.     require Data::Dumper;
  345.  
  346.     if (!open(CACHE, ">" . _cache_file())) {
  347.     warn "Can't write to cache file " . _cache_file();
  348.     } else {
  349.     my $dd = Data::Dumper->new([$self->{pods}], ['pods']);
  350.     $dd->Indent(0);
  351.     print CACHE $dd->Dump;
  352.     close CACHE;
  353.     }
  354. }
  355.  
  356. =head2 LoadCache()
  357.  
  358. Load the Pod cache, if possible.
  359.  
  360. =cut
  361.  
  362. sub LoadCache {
  363.     my $self = shift;
  364.     my $cache_file = _cache_file();
  365.     if (-r $cache_file) {
  366.     return if $< != (stat($cache_file))[4];
  367.     require Safe;
  368.     my $c = Safe->new('Tk::Pod::FindPods::SAFE');
  369.     $c->rdo($cache_file);
  370.     if (keys %$Tk::Pod::FindPods::SAFE::pods) {
  371.         $self->{pods} = { %$Tk::Pod::FindPods::SAFE::pods };
  372.         return $self->{pods};
  373.     }
  374.     }
  375.     return {};
  376. }
  377.  
  378. return 1 if caller;
  379.  
  380. package main;
  381.  
  382. require Data::Dumper;
  383. print Data::Dumper->Dumpxs([{Tk::Pod::FindPods::pod_find(-categorized => 0, -usecache => 0)}],[]);
  384.  
  385. __END__
  386.  
  387. =head1 SEE ALSO
  388.  
  389. Tk::Tree(3).
  390.  
  391. =head1 AUTHOR
  392.  
  393. Slaven Rezic <F<slaven@rezic.de>>
  394.  
  395. Copyright (c) 2001,2003 Slaven Rezic.  All rights reserved.  This program
  396. is free software; you can redistribute it and/or modify it under the same
  397. terms as Perl itself.
  398.  
  399. =cut
  400.