home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _cdc7e0ce8dd2bbb1a7cb7ad1c57bee83 < prev    next >
Encoding:
Text File  |  2004-04-13  |  8.6 KB  |  352 lines
  1. package ActivePerl::DocTools::TOC;
  2.  
  3. use strict;
  4. use warnings;
  5.  
  6. use File::Basename;
  7. use File::Find;
  8. use Config;
  9. use Symbol;
  10.  
  11. # get a default value for $dirbase ... can be overridden? yes, see makefile for details
  12. our $dirbase;
  13. if (defined $Config{installhtmldir}) {
  14.     $dirbase = $Config{installhtmldir};
  15. }
  16. else {
  17.     $dirbase = "$Config{installprefix}/html";
  18. }
  19.  
  20. my @corePodz = qw(
  21. perl  perlintro  perltoc
  22.     __
  23. perlreftut  perldsc  perllol
  24.     __
  25. perlrequick  perlretut
  26.     __
  27. perlboot  perltoot  perltooc  perlbot
  28.     __
  29. perlstyle
  30.     __
  31. perlcheat  perltrap  perldebtut
  32.     __
  33. perlfaq1  perlfaq2  perlfaq3  perlfaq4  perlfaq5  perlfaq6  perlfaq7  perlfaq8  perlfaq9
  34.     __
  35. perlsyn  perldata  perlop  perlsub  perlfunc  perlopentut  perlpacktut
  36.     __
  37. perlpod  perlpodspec  perlrun  perldiag  perllexwarn  perldebug  perlvar  perlre  perlreref  perlref  perlform  perlobj  perltie  perldbmfilter
  38.     __
  39. perlipc  perlfork  perlnumber
  40.     __
  41. perlthrtut  perlothrtut
  42.     __
  43. perlport  perllocale  perluniintro  perlunicode  perlebcdic
  44.     __
  45. perlsec
  46.     __
  47. perlmod  perlmodlib  perlmodstyle  perlmodinstall  perlnewmod
  48.     __
  49. perlutil
  50.     __
  51. perlcompile
  52.     __
  53. perlfilter
  54.     __
  55. perlembed  perldebguts  perlxstut  perlxs  perlclib  perlguts  perlcall
  56.     __
  57. perlapi  perlintern  perliol  perlapio
  58.     __
  59. perlhack
  60.     __
  61. perlbook  perltodo
  62.     __
  63. perlhist  perldelta  perl582delta  perl581delta  perl58delta  perl573delta  perl572delta  perl571delta  perl570delta  perl561delta  perl56delta  perl5005delta  perl5004delta
  64.     __
  65. perlcn  perljp  perlko  perltw
  66.     __
  67. perlaix  perlamiga  perlapollo  perlbeos  perlbs2000  perlce  perlcygwin  perldgux  perldos  perlepoc  perlfreebsd  perlhpux  perlhurd  perlirix  perlmachten  perlmacos  perlmacosx  perlmint  perlmpeix  perlnetware  perlos2  perlos390  perlos400  perlplan9  perlqnx  perlsolaris  perltru64  perluts  perlvmesa  perlvms  perlvos  perlwin32
  68.         );
  69.  
  70.  
  71. # LIST OF METHODS TO OVERRIDE IN YOUR SUBCLASS
  72. {
  73.     no strict "refs";  # trust me, I know what I'm doing
  74.     for my $abstract_method (qw/
  75.     header
  76.     before_pods pod_separator pod after_pods
  77.     before_scripts script after_scripts
  78.     before_pragmas pragma after_pragmas
  79.     before_libraries library library_indent_open library_indent_close library_indent_same library_container after_libraries
  80.     footer/) {
  81.     *$abstract_method = sub { die "The subroutine $abstract_method() must be overriden by the child class!" };
  82.     };
  83. }
  84.  
  85.  
  86. sub new {
  87.     my ($invocant, $options) = @_;
  88.     my $class = ref($invocant) || $invocant;  # object or class name.
  89.     my $self;
  90.  
  91.     if (ref($options) eq 'HASH') {
  92.     $self = $options;
  93.     } else {
  94.     $self = {};
  95.     }
  96.     _BuildHashes($self);
  97.  
  98.     bless ($self, $class);
  99.     return $self;
  100. }
  101.  
  102.  
  103. # generic structure for the website, HTML help, RDF
  104. sub TOC {
  105.     # warn "entered Write";
  106.     my ($self) = @_;
  107.  
  108.     my $verbose = $self->{'verbose'};
  109.  
  110.     my $output;
  111.  
  112.     my %filez = %{$self->{'filez'}};
  113.     my %pragmaz = %{$self->{'pragmaz'}};
  114.     my %podz = %{$self->{'podz'}};
  115.     my %scriptz = %{$self->{'scriptz'}};
  116.  
  117.     # generic header stuff
  118.  
  119.     $output .= $self->boilerplate();
  120.  
  121.     $output .= $self->header();
  122.  
  123.     # core pods
  124.  
  125.     my %unused_podz = %podz;
  126.  
  127.     $output .= $self->before_pods();
  128.  
  129.     foreach my $file (@corePodz) {
  130.     if ($file eq '__') {
  131.         $output .= $self->pod_separator();
  132.     } elsif ($podz{"Pod::$file"}) {
  133.         $output .= $self->pod($file);
  134.         delete $unused_podz{"Pod::$file"};
  135.     } else {
  136.         warn "Couldn't find pod for $file" if $verbose;
  137.     }
  138.     }
  139.  
  140.     foreach my $file (sort keys %unused_podz) {
  141.     warn "Unused Pod: $file" if $verbose;
  142.     }
  143.  
  144.     $output .= $self->after_pods();
  145.  
  146.     $output .= $self->before_scripts();
  147.  
  148.     # scripts
  149.  
  150.     foreach my $file (sort keys %scriptz) {
  151.     $output .= $self->script($file);
  152.     }
  153.  
  154.     $output .= $self->after_scripts();
  155.  
  156.     # pragmas (or pragmata to the pedantic :)
  157.  
  158.     $output .= $self->before_pragmas();
  159.  
  160.     foreach my $file (sort keys %pragmaz) {
  161.     $output .= $self->pragma($file)
  162.     }
  163.  
  164.     $output .= $self->after_pragmas();
  165.  
  166.     # libraries
  167.     $output .= $self->before_libraries();
  168.  
  169.     my $depth=0;
  170.  
  171.     foreach my $file (sort {uc($a) cmp uc($b)} keys %filez) {
  172.  
  173.     my $showfile=$file;
  174.     my $file_depth=0;
  175.     my $depthflag=0;
  176.  
  177.     # cuts $showfile down to its last part, i.e. Foo::Baz::Bar --> Bar
  178.     # and counts the number of times, to get indent. --> 2
  179.     while ($showfile =~ s/.*?::(.*)/$1/) { $file_depth++ }
  180.  
  181.     # if the current file's depth is further out or in than last time,
  182.     # add opening or closing tags.
  183.     while ($file_depth != $depth) {
  184.         if ($file_depth > $depth) {
  185.         $output .= $self->library_indent_open();
  186.         $depth++;
  187.         $depthflag=1;
  188.         }
  189.         elsif ($file_depth < $depth) {
  190.         $output .= $self->library_indent_close();
  191.         $depth--;
  192.         $depthflag=1;
  193.         }
  194.     }
  195.  
  196.     unless ($depthflag) {
  197.         $output .= $self->library_indent_same();
  198.     }
  199.  
  200.     if ($filez{$file}) {
  201.         $output .= $self->library($file, $showfile, $depth);
  202.     } else {
  203.         # assume this is a containing item like a folder or something
  204.         $output .= $self->library_container($file, $showfile, $depth);
  205.     }
  206.     }
  207.  
  208.     $output .= $self->after_libraries();
  209.     $output .= $self->footer();
  210.  
  211.     return $output;
  212. }
  213.  
  214.  
  215. sub _BuildHashes {
  216.  
  217.     my ($self) = shift;
  218.     my $verbose = $self->{'verbose'};
  219.  
  220.     unless (-d $dirbase) {
  221.     die "htmldir not found at: $dirbase";
  222.     }
  223.  
  224.     #warn "entered buildhashes";
  225.  
  226.     my @checkdirs = qw(bin lib site/lib);
  227.  
  228.     my (%filez, %pragmaz, %podz, %scriptz);
  229.  
  230.     my $Process = sub {
  231.     return if -d;
  232.     my $parsefile = $_;
  233.  
  234.     my ($filename,$dir,$suffix) = fileparse($parsefile,'\.html');
  235.  
  236.     if ($suffix !~ m#\.html#) { return; }
  237.  
  238.     my $TOCdir = $dir;
  239.  
  240.     $filename =~ s/(.*)\..*/$1/;
  241.  
  242. #    print "$TOCdir";
  243.     my $ver = $Config{version};
  244.     my $an = $Config{archname};
  245.     if ($TOCdir =~ s#^.*?(bin/)(\Q$an\E/)?(.*)$#$3#) {
  246.         $scriptz{"$TOCdir$filename"} = "bin/$filename.html";
  247.         return 1;
  248.     }
  249.     $TOCdir =~ s#^.*?(lib/site_perl/\Q$ver\E/|lib/\Q$ver\E/|lib/)(\Q$an\E/)?(.*)$#$3#;
  250.     $TOCdir =~ s#/#::#g;
  251.     $TOCdir =~ s#^pod::#Pod::#; #Pod dir is uppercase in Win32
  252. #    print " changed to: $TOCdir\n";
  253.     $dir =~ s#.*?/((site/)?lib.*?)/$#$1#; #looks ugly to get around warning
  254.  
  255.     if ($filez{"$TOCdir/$filename.html"}) {
  256.         warn "$parsefile: REPEATED!\n";
  257.     }
  258.     $filez{"$TOCdir$filename"} = "$dir/$filename.html";
  259. #    print "adding $parsefile as " . $filez{"$TOCdir/$filename.html"} . "\n";
  260. #    print "\%filez{$TOCdir$filename.html}: " . $filez{"$TOCdir$filename.html"} . "\n";
  261.  
  262.     return 1;
  263.     };
  264.  
  265.     foreach my $dir (@checkdirs) {
  266.     find ( { wanted => $Process, no_chdir => 1 }, "$dirbase/$dir")
  267.         if -d "$dirbase/$dir";
  268.     }
  269.  
  270.     foreach my $file (keys %filez) {
  271.     if ($file =~ /^[a-z]/) {  # pragmas in perl are denoted by all lowercase...
  272.         if ($file ne 'perlfilter' 
  273.         and $file ne 'lwpcook' 
  274.         and $file ne 'lwptut' 
  275.         and $file ne 'perllocal') 
  276.         {   # ... except these. sigh. Yes, Dave, it's their fault, but we ought to fix it anyway.
  277.         $pragmaz{$file} = $filez{$file};
  278.         delete $filez{$file};
  279.         }
  280.     } elsif ($file =~ /^Pod::perl/) {
  281.         $podz{$file} = $filez{$file};
  282.         delete $filez{$file};
  283.     } elsif ($file eq 'Pod::PerlEz'
  284.         or $file =~ /^ActivePerl/
  285.         or $file =~ /^ActiveState/
  286.         or $file =~ /^ASRemote/
  287.         or $file =~ /^PPM/)
  288.         {
  289.         #these files are internal and support files
  290.         delete $filez{$file};
  291.     }
  292.     }
  293.  
  294.     foreach my $file (sort {uc($b) cmp uc($a)} keys %filez) {
  295.     my $prefix = $file;
  296.     while ($prefix =~ s/(.*)?::(.*)/$1/) {
  297.         if (! defined ($filez{$prefix})) {
  298.         $filez{$prefix} = '';
  299.         warn "Added topic: $prefix\n" if $verbose;
  300.         }
  301.         warn " $prefix from $file\n" if $verbose;
  302.     }
  303.     }
  304.  
  305.     $self->{'filez'} = \%filez;
  306.     $self->{'podz'} = \%podz;
  307.     $self->{'pragmaz'} = \%pragmaz;
  308.     $self->{'scriptz'} = \%scriptz;
  309. }
  310.  
  311. sub text {
  312.     my ($text) =  join '', map { "$_\n" } @_;
  313.     return sub { $text };
  314. }
  315.  
  316. 1;
  317.  
  318. __END__
  319.  
  320. #=head1 NAME
  321.  
  322. ActivePerl::DocTools::TOC- base class for generating Perl documentation TOC
  323.  
  324. #=head1 SYNOPSIS
  325.  
  326.   use base ('ActivePerl::DocTools::TOC');
  327.  
  328.   # override lots of methods here... see source for which ones
  329.  
  330. #=head1 DESCRIPTION
  331.  
  332. Base class for generating TOC's from Perl html docs.
  333.  
  334. #=head2 EXPORTS
  335.  
  336. $dirbase - where the html files are
  337.  
  338. #=head1 AUTHOR
  339.  
  340. David Sparks, DaveS@ActiveState.com
  341. Neil Kandalgaonkar, NeilK@ActiveState.com
  342.  
  343. #=head1 SEE ALSO
  344.  
  345. The amazing L<PPM>.
  346.  
  347. L<ActivePerl::DocTools::TOC::HTML>
  348.  
  349. L<ActivePerl::DocTools::TOC::RDF>
  350.  
  351. #=cut
  352.