Ticket #134: pod_update.diff

File pod_update.diff, 173.0 KB (added by geraud, 6 years ago)
  • MANIFEST

     
    27962796lib/Pod/Simple/DumpAsText.pm                                [devel] 
    27972797lib/Pod/Simple/DumpAsXML.pm                                 [devel] 
    27982798lib/Pod/Simple/HTML.pm                                      [devel] 
     2799lib/Pod/Simple/HTMLBatch.pm                                 [devel] 
     2800lib/Pod/Simple/HTMLLegacy.pm                                [devel] 
    27992801lib/Pod/Simple/LinkSection.pm                               [devel] 
    28002802lib/Pod/Simple/Methody.pm                                   [devel] 
     2803lib/Pod/Simple/Progress.pm                                  [devel] 
    28012804lib/Pod/Simple/PullParser.pm                                [devel] 
    28022805lib/Pod/Simple/PullParserEndToken.pm                        [devel] 
    28032806lib/Pod/Simple/PullParserStartToken.pm                      [devel] 
    28042807lib/Pod/Simple/PullParserTextToken.pm                       [devel] 
    28052808lib/Pod/Simple/PullParserToken.pm                           [devel] 
    28062809lib/Pod/Simple/RTF.pm                                       [devel] 
     2810lib/Pod/Simple/Search.pm                                    [devel] 
    28072811lib/Pod/Simple/SimpleTree.pm                                [devel] 
    28082812lib/Pod/Simple/Text.pm                                      [devel] 
    28092813lib/Pod/Simple/TextContent.pm                               [devel] 
     
    28112815lib/Pod/Simple/Transcode.pm                                 [devel] 
    28122816lib/Pod/Simple/TranscodeDumb.pm                             [devel] 
    28132817lib/Pod/Simple/TranscodeSmart.pm                            [devel] 
     2818lib/Pod/Simple/XHTML.pm                                     [devel] 
    28142819lib/Pod/Simple/XMLOutStream.pm                              [devel] 
    28152820parrot.spec                                                 [] 
    28162821parrotbug                                                   [] 
  • lib/Pod/Simple.pm

     
    1818); 
    1919 
    2020@ISA = ('Pod::Simple::BlackBox'); 
    21 $VERSION = '2.05'; 
     21$VERSION = '3.07'; 
    2222 
    2323@Known_formatting_codes = qw(I B C L E F S X Z);  
    2424%Known_formatting_codes = map(($_=>1), @Known_formatting_codes); 
     
    8080  'bare_output',       # For some subclasses: whether to prepend 
    8181                       #  header-code and postpend footer-code 
    8282 
     83  'fullstop_space_harden', # Whether to turn ".  " into ".[nbsp] "; 
     84 
    8385  'nix_X_codes',       # whether to ignore X<...> codes 
    8486  'merge_text',        # whether to avoid breaking a single piece of 
    8587                       #  text up into several events 
    8688 
     89  'preserve_whitespace', # whether to try to keep whitespace as-is 
     90 
    8791 'content_seen',      # whether we've seen any real Pod content 
    8892 'errors_seen',       # TODO: document.  whether we've seen any errors (fatal or not) 
    8993 
     94 'codes_in_verbatim', # for PseudoPod extensions 
     95 
    9096 'code_handler',      # coderef to call when a code (non-pod) line is seen 
    9197 'cut_handler',       # coderef to call when a =cut line is seen 
    9298 #Called like: 
     
    139145  $$x = '' unless defined $$x; 
    140146  DEBUG > 4 and print "# Output string set to $x ($$x)\n"; 
    141147  $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]); 
    142   return $this->{'output_string'} = ${ $this->{'output_fh'} }; 
     148  return 
     149    $this->{'output_string'} = $_[0]; 
     150    #${ ${ $this->{'output_fh'} } }; 
    143151} 
    144152 
     153sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} } 
     154sub abandon_output_fh     { $_[0]->output_fh(undef) } 
     155# These don't delete the string or close the FH -- they just delete our 
     156#  references to it/them. 
     157# TODO: document these 
     158 
    145159#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 
    146160 
    147161sub new { 
     
    969983  # L<text|name/"sec"> or L<text|name/sec> 
    970984  # L<text|/"sec"> or L<text|/sec> or L<text|"sec"> 
    971985  # L<scheme:...> 
     986  # Ltext|scheme:...> 
    972987 
    973988  my($self,@stack) = @_; 
    974989 
     
    9881003       
    9891004       
    9901005      # By here, $treelet->[$i] is definitely an L node 
    991       DEBUG > 1 and print "Ogling L node $treelet->[$i]\n"; 
     1006      my $ell = $treelet->[$i]; 
     1007      DEBUG > 1 and print "Ogling L node $ell\n"; 
    9921008         
    9931009      # bitch if it's empty 
    994       if(  @{$treelet->[$i]} == 2 
    995        or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '') 
     1010      if(  @{$ell} == 2 
     1011       or (@{$ell} == 3 and $ell->[2] eq '') 
    9961012      ) { 
    9971013        $self->whine( $start_line, "An empty L<>" ); 
    9981014        $treelet->[$i] = 'L<>';  # just make it a text node 
     
    10001016      } 
    10011017      
    10021018      # Catch URLs: 
    1003       # URLs can, alas, contain E<...> sequences, so we can't /assume/ 
    1004       #  that this is one text node.  But it has to START with one text 
    1005       #  node... 
    1006       if(! ref $treelet->[$i][2] and 
    1007         $treelet->[$i][2] =~ m/^\w+:[^:\s]\S*$/s 
     1019 
     1020      # there are a number of possible cases: 
     1021      # 1) text node containing url: http://foo.com 
     1022      #   -> [ 'http://foo.com' ] 
     1023      # 2) text node containing url and text: foo|http://foo.com 
     1024      #   -> [ 'foo|http://foo.com' ] 
     1025      # 3) text node containing url start: mailto:xE<at>foo.com 
     1026      #   -> [ 'mailto:x', [ E ... ], 'foo.com' ] 
     1027      # 4) text node containing url start and text: foo|mailto:xE<at>foo.com 
     1028      #   -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ] 
     1029      # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com 
     1030      #   -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ] 
     1031      # ... etc. 
     1032 
     1033      # anything before the url is part of the text. 
     1034      # anything after it is part of the url. 
     1035      # the url text node itself may contain parts of both. 
     1036 
     1037      if (my ($url_index, $text_part, $url_part) = 
     1038        # grep is no good here; we want to bail out immediately so that we can 
     1039        # use $1, $2, etc. without having to do the match twice. 
     1040        sub { 
     1041          for (2..$#$ell) { 
     1042            next if ref $ell->[$_]; 
     1043            next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s; 
     1044            return ($_, $1, $2); 
     1045          } 
     1046          return; 
     1047        }->() 
    10081048      ) { 
    1009         $treelet->[$i][1]{'type'} = 'url'; 
    1010         $treelet->[$i][1]{'content-implicit'} = 'yes'; 
    1011          
    1012         if( 3 == @{ $treelet->[$i] } ) { 
    1013           # But if it IS just one text node (most common case) 
    1014           DEBUG > 1 and printf qq{Catching "%s as " as ho-hum L<URL> link.\n}, 
    1015             $treelet->[$i][2] 
    1016           ; 
    1017           $treelet->[$i][1]{'to'} = Pod::Simple::LinkSection->new( 
    1018             $treelet->[$i][2] 
    1019           );                   # its own treelet 
    1020         } else { 
    1021           # It's a URL but complex (like "L<foo:bazE<123>bar>").  Feh. 
    1022           #$treelet->[$i][1]{'to'} = [ @{$treelet->[$i]} ]; 
    1023           #splice @{ $treelet->[$i][1]{'to'} }, 0,2; 
    1024           #DEBUG > 1 and printf qq{Catching "%s as " as complex L<URL> link.\n}, 
    1025           #  join '~', @{$treelet->[$i][1]{'to'  }}; 
    1026            
    1027           $treelet->[$i][1]{'to'} = Pod::Simple::LinkSection->new( 
    1028             $treelet->[$i]  # yes, clone the whole content as a treelet 
    1029           ); 
    1030           $treelet->[$i][1]{'to'}[0] = ''; # set the copy's tagname to nil 
    1031           die "SANITY FAILURE" if $treelet->[0] eq ''; # should never happen! 
    1032           DEBUG > 1 and print 
    1033            qq{Catching "$treelet->[$i][1]{'to'}" as a complex L<URL> link.\n}; 
     1049        $ell->[1]{'type'} = 'url'; 
     1050 
     1051        my @text = @{$ell}[2..$url_index-1]; 
     1052        push @text, $text_part if defined $text_part; 
     1053 
     1054        my @url  = @{$ell}[$url_index+1..$#$ell]; 
     1055        unshift @url, $url_part; 
     1056 
     1057        unless (@text) { 
     1058          $ell->[1]{'content-implicit'} = 'yes'; 
     1059          @text = @url; 
    10341060        } 
    10351061 
    1036         next; # and move on 
     1062        $ell->[1]{to} = Pod::Simple::LinkSection->new( 
     1063          @url == 1 
     1064          ? $url[0] 
     1065          : [ '', {}, @url ], 
     1066        ); 
     1067 
     1068        splice @$ell, 2, $#$ell, @text; 
     1069 
     1070        next; 
    10371071      } 
    10381072       
    1039        
    10401073      # Catch some very simple and/or common cases 
    1041       if(@{$treelet->[$i]} == 3 and ! ref $treelet->[$i][2]) { 
    1042         my $it = $treelet->[$i][2]; 
     1074      if(@{$ell} == 3 and ! ref $ell->[2]) { 
     1075        my $it = $ell->[2]; 
    10431076        if($it =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s) { # man sections 
    10441077          # Hopefully neither too broad nor too restrictive a RE 
    10451078          DEBUG > 1 and print "Catching \"$it\" as manpage link.\n"; 
    1046           $treelet->[$i][1]{'type'} = 'man'; 
     1079          $ell->[1]{'type'} = 'man'; 
    10471080          # This's the only place where man links can get made. 
    1048           $treelet->[$i][1]{'content-implicit'} = 'yes'; 
    1049           $treelet->[$i][1]{'to'  } = 
     1081          $ell->[1]{'content-implicit'} = 'yes'; 
     1082          $ell->[1]{'to'  } = 
    10501083            Pod::Simple::LinkSection->new( $it ); # treelet! 
    10511084 
    10521085          next; 
     
    10551088          # Extremely forgiving idea of what constitutes a bare 
    10561089          #  modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala> 
    10571090          DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n"; 
    1058           $treelet->[$i][1]{'type'} = 'pod'; 
    1059           $treelet->[$i][1]{'content-implicit'} = 'yes'; 
    1060           $treelet->[$i][1]{'to'  } = 
     1091          $ell->[1]{'type'} = 'pod'; 
     1092          $ell->[1]{'content-implicit'} = 'yes'; 
     1093          $ell->[1]{'to'  } = 
    10611094            Pod::Simple::LinkSection->new( $it ); # treelet! 
    10621095          next; 
    10631096        } 
     
    10731106       
    10741107       
    10751108      my $link_text; # set to an arrayref if found 
    1076       my $ell = $treelet->[$i]; 
    10771109      my @ell_content = @$ell; 
    10781110      splice @ell_content,0,2; # Knock off the 'L' and {} bits 
    10791111 
     
    13571389        $i +=  @$to_pull_up - 1;   # Make $i skip the pulled-up stuff 
    13581390      } 
    13591391    } else { 
    1360       $treelet->[$i] =~ tr/ /\xA0/ if ASCII and $in_s; 
     1392      $treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s; 
    13611393       # (If not in ASCIIland, we can't assume that \xA0 == nbsp.) 
    13621394        
    13631395       # Note that if you apply nbsp_for_S to text, and so turn 
     
    14271459   "\nAbout to parse source: {{\n$_[0]\n}}\n\n"; 
    14281460   
    14291461   
    1430   my $parser = $class->new; 
     1462  my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new; 
    14311463  $parser->hide_line_numbers(1); 
    14321464 
    14331465  my $out = ''; 
  • lib/Pod/Simple/XMLOutStream.pm

     
    113113L<Pod::Simple::DumpAsXML> is rather like this class; see its 
    114114documentation for a discussion of the differences. 
    115115 
    116 L<Pod::Simple>, L<Pod::Simple::DumpAsXML> 
     116L<Pod::Simple>, L<Pod::Simple::DumpAsXML>, L<Pod::SAX> 
    117117 
    118 The older libraries L<Pod::PXML>, L<Pod::XML>, L<Pod::SAX> 
     118L<Pod::Simple::Subclassing> 
    119119 
     120The older (and possibly obsolete) libraries L<Pod::PXML>, L<Pod::XML> 
    120121 
     122 
     123=head1 ABOUT EXTENDING POD 
     124 
     125TODO: An example or two of =extend, then point to Pod::Simple::Subclassing 
     126 
     127 
     128=head1 ASK ME! 
     129 
     130If you actually want to use Pod as a format that you want to render to 
     131XML (particularly if to an XML instance with more elements than normal 
     132Pod has), please email me (C<sburke@cpan.org>) and I'll probably have 
     133some recommendations. 
     134 
     135For reasons of concision and energetic laziness, some methods and 
     136options in this module (and the dozen modules it depends on) are 
     137undocumented; but one of those undocumented bits might be just what 
     138you're looking for. 
     139 
     140 
    121141=head1 COPYRIGHT AND DISCLAIMERS 
    122142 
    123 Copyright (c) 2002 Sean M. Burke.  All rights reserved. 
     143Copyright (c) 2002-4 Sean M. Burke.  All rights reserved. 
    124144 
    125145This library is free software; you can redistribute it and/or modify it 
    126146under the same terms as Perl itself. 
  • lib/Pod/Simple/HTML.pm

     
    33package Pod::Simple::HTML; 
    44use strict; 
    55use Pod::Simple::PullParser (); 
    6 use vars qw(@ISA %Tagmap $Computerese $Lame $Linearization_Limit $VERSION); 
     6use vars qw( 
     7  @ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION 
     8  $Perldoc_URL_Prefix $Perldoc_URL_Postfix 
     9  $Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex 
     10  $Doctype_decl  $Content_decl 
     11); 
    712@ISA = ('Pod::Simple::PullParser'); 
    8 $VERSION = '2.02'; 
     13$VERSION = '3.03'; 
    914 
    1015use UNIVERSAL (); 
    11 sub DEBUG () {0} 
     16BEGIN { 
     17  if(defined &DEBUG) { } # no-op 
     18  elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } 
     19  else { *DEBUG = sub () {0}; } 
     20} 
    1221 
    13 $Computerese =  " lang='und' xml:lang='und'" unless defined $Computerese; 
    14 $Lame = ' class="pad"' unless defined $Lame; 
     22$Doctype_decl ||= '';  # No.  Just No.  Don't even ask me for it. 
     23 # qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" 
     24 #    "http://www.w3.org/TR/html4/loose.dtd">\n}; 
    1525 
    16 $Linearization_Limit = 90 unless defined $Linearization_Limit; 
     26$Content_decl ||= 
     27 q{<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" >}; 
     28 
     29$HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION; 
     30$Computerese =  "" unless defined $Computerese; 
     31$LamePad = '' unless defined $LamePad; 
     32 
     33$Linearization_Limit = 120 unless defined $Linearization_Limit; 
    1734 # headings/items longer than that won't get an <a name="..."> 
     35$Perldoc_URL_Prefix  = 'http://search.cpan.org/perldoc?' 
     36 unless defined $Perldoc_URL_Prefix; 
     37$Perldoc_URL_Postfix = '' 
     38 unless defined $Perldoc_URL_Postfix; 
    1839 
     40$Title_Prefix  = '' unless defined $Title_Prefix; 
     41$Title_Postfix = '' unless defined $Title_Postfix; 
     42%ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text 
     43  # 'item-text' stuff in the index doesn't quite work, and may 
     44  # not be a good idea anyhow. 
     45 
     46 
     47__PACKAGE__->_accessorize( 
     48 'perldoc_url_prefix', 
     49   # In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what 
     50   #  to put before the "Foo%3a%3aBar". 
     51   # (for singleton mode only?) 
     52 'perldoc_url_postfix', 
     53   # what to put after "Foo%3a%3aBar" in the URL.  Normally "". 
     54 
     55 'batch_mode', # whether we're in batch mode 
     56 'batch_mode_current_level', 
     57    # When in batch mode, how deep the current module is: 1 for "LWP", 
     58    #  2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc 
     59     
     60 'title_prefix',  'title_postfix', 
     61  # What to put before and after the title in the head. 
     62  # Should already be &-escaped 
     63   
     64 'html_header_before_title', 
     65 'html_header_after_title', 
     66 'html_footer', 
     67 
     68 'index', # whether to add an index at the top of each page 
     69    # (actually it's a table-of-contents, but we'll call it an index, 
     70    #  out of apparently longstanding habit) 
     71 
     72 'html_css', # URL of CSS file to point to 
     73 'html_javascript', # URL of CSS file to point to 
     74 
     75 'force_title',   # should already be &-escaped 
     76 'default_title', # should already be &-escaped 
     77); 
     78 
    1979#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    2080my @_to_accept; 
    2181 
     
    77137    ]  # no point in providing a way to get <q>...</q>, I think 
    78138  ), 
    79139   
    80   '/item-bullet' => "</li><p$Lame></p>\n", 
    81   '/item-number' => "</li><p$Lame></p>\n", 
    82   '/item-text'   => "</a></dt><p$Lame></p>\n", 
    83   'Para_item'    => "\n<dd>", 
    84   '/Para_item'   => "</dd><p$Lame></p>\n", 
     140  '/item-bullet' => "</li>$LamePad\n", 
     141  '/item-number' => "</li>$LamePad\n", 
     142  '/item-text'   => "</a></dt>$LamePad\n", 
     143  'item-body'    => "\n<dd>", 
     144  '/item-body'   => "</dd>\n", 
    85145 
     146 
    86147  'B'      =>  "<b>",                  '/B'     =>  "</b>", 
    87148  'I'      =>  "<i>",                  '/I'     =>  "</i>", 
    88149  'F'      =>  "<em$Computerese>",     '/F'     =>  "</em>", 
     
    103164} 
    104165 
    105166#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     167sub go { Pod::Simple::HTML->parse_from_file(@ARGV); exit 0 } 
     168 # Just so we can run from the command line.  No options. 
     169 #  For that, use perldoc! 
     170#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    106171 
    107172sub new { 
    108173  my $new = shift->SUPER::new(@_); 
     
    112177  $new->accept_codes('VerbatimFormatted'); 
    113178  $new->accept_codes(@_to_accept); 
    114179  DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n"; 
    115    
     180 
     181  $new->perldoc_url_prefix(  $Perldoc_URL_Prefix  ); 
     182  $new->perldoc_url_postfix( $Perldoc_URL_Postfix ); 
     183  $new->title_prefix(  $Title_Prefix  ); 
     184  $new->title_postfix( $Title_Postfix ); 
     185 
     186  $new->html_header_before_title( 
     187   qq[$Doctype_decl<html><head><title>] 
     188  ); 
     189  $new->html_header_after_title( join "\n" => 
     190    "</title>", 
     191    $Content_decl, 
     192    "</head>\n<body class='pod'>", 
     193    $new->version_tag_comment, 
     194    "<!-- start doc -->\n", 
     195  ); 
     196  $new->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] ); 
     197 
    116198  $new->{'Tagmap'} = {%Tagmap}; 
    117199  return $new; 
    118200} 
    119201 
     202sub batch_mode_page_object_init { 
     203  my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_; 
     204  DEBUG and print "Initting $self\n  for $module\n", 
     205    "  in $infile\n  out $outfile\n  depth $depth\n"; 
     206  $self->batch_mode(1); 
     207  $self->batch_mode_current_level($depth); 
     208  return $self; 
     209} 
     210 
    120211sub run { 
    121212  my $self = $_[0]; 
    122213  return $self->do_middle if $self->bare_output; 
     
    126217 
    127218#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    128219 
    129 sub do_pod_link { 
    130   my($self, $link) = @_; 
    131   my $to = $link->attr('to'); 
    132   my $section = $link->attr('section'); 
    133   return undef unless(  # should never happen 
    134     (defined $to and length $to) or 
    135     (defined $section and length $section) 
    136   ); 
     220sub do_beginning { 
     221  my $self = $_[0]; 
    137222 
    138   if(defined $to and length $to) { 
    139     $to = $self->resolve_pod_page_link($to, $section); 
    140     return undef unless defined $to and length $to; 
    141      # resolve_pod_page_link returning undef is how it 
    142      #  can signal that it gives up on making a link 
    143      # (I pass it the section value, but I don't see a 
    144      #  particular reason it'd use it.) 
     223  my $title; 
     224   
     225  if(defined $self->force_title) { 
     226    $title = $self->force_title; 
     227    DEBUG and print "Forcing title to be $title\n"; 
     228  } else { 
     229    # Actually try looking for the title in the document: 
     230    $title = $self->get_short_title(); 
     231    unless($self->content_seen) { 
     232      DEBUG and print "No content seen in search for title.\n"; 
     233      return; 
     234    } 
     235    $self->{'Title'} = $title; 
     236 
     237    if(defined $title and $title =~ m/\S/) { 
     238      $title = $self->title_prefix . esc($title) . $self->title_postfix; 
     239    } else { 
     240      $title = $self->default_title;     
     241      $title = '' unless defined $title; 
     242      DEBUG and print "Title defaults to $title\n"; 
     243    } 
    145244  } 
     245 
    146246   
    147   if(defined $section and length($section .= '')) { 
    148     $section =~ tr/ /_/; 
    149     $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); 
    150     $section = $self->unicode_escape_url($section); 
    151      # Turn char 1234 into "(1234)" 
    152     $section = '_' unless length $section; 
     247  my $after = $self->html_header_after_title  || ''; 
     248  if($self->html_css) { 
     249    my $link = 
     250    $self->html_css =~ m/</ 
     251     ? $self->html_css # It's a big blob of markup, let's drop it in 
     252     : sprintf(        # It's just a URL, so let's wrap it up 
     253      qq[<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="%s">\n], 
     254      $self->html_css, 
     255    ); 
     256    $after =~ s{(</head>)}{$link\n$1}i;  # otherwise nevermind 
    153257  } 
    154    
    155    
     258  $self->_add_top_anchor(\$after); 
    156259 
    157   foreach my $it ($to, $section) { 
    158     if( defined $it ) { 
    159       $it =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg; 
    160       $it =~ s/([^\._abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg; 
    161        # Yes, stipulate the list without a range, so that this can work right on 
    162        #  all charsets that this module happens to run under. 
    163        # Altho, hmm, what about that ord?  Presumably that won't work right 
    164        #  under non-ASCII charsets.  Something should be done about that. 
    165     } 
     260  if($self->html_javascript) { 
     261    my $link = 
     262    $self->html_javascript =~ m/</ 
     263     ? $self->html_javascript # It's a big blob of markup, let's drop it in 
     264     : sprintf(        # It's just a URL, so let's wrap it up 
     265      qq[<script type="text/javascript" src="%s"></script>\n], 
     266      $self->html_javascript, 
     267    ); 
     268    $after =~ s{(</head>)}{$link\n$1}i;  # otherwise nevermind 
    166269  } 
    167    
    168   my $out = $to if defined $to and length $to; 
    169   $out .= "#" . $section if defined $section and length $section; 
    170   return undef unless length $out; 
    171   return $out;   
     270 
     271  print {$self->{'output_fh'}} 
     272    $self->html_header_before_title || '', 
     273    $title, # already escaped 
     274    $after, 
     275  ; 
     276 
     277  DEBUG and print "Returning from do_beginning...\n"; 
     278  return 1; 
    172279} 
    173280 
     281sub _add_top_anchor { 
     282  my($self, $text_r) = @_; 
     283  unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack 
     284    $$text_r .= "<a name='___top' class='dummyTopAnchor' ></a>\n"; 
     285  } 
     286  return; 
     287} 
    174288 
    175 sub resolve_pod_page_link { 
    176   my($self, $to) = @_; 
    177    
    178   return 'TODO'; 
     289sub version_tag_comment { 
     290  my $self = shift; 
     291  return sprintf 
     292   "<!--\n  generated by %s v%s,\n  using %s v%s,\n  under Perl v%s at %s GMT.\n\n %s\n\n-->\n", 
     293   esc( 
     294    ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(), 
     295    $], scalar(gmtime), 
     296   ), $self->_modnote(), 
     297  ; 
    179298} 
    180299 
    181 sub do_url_link { return $_[1]->attr('to') } 
     300sub _modnote { 
     301  my $class = ref($_[0]) || $_[0]; 
     302  return join "\n   " => grep m/\S/, split "\n", 
    182303 
    183 sub do_man_link { return undef } 
    184  # But subclasses are welcome to override this if they have man 
    185  #  pages somewhere URL-accessible. 
     304qq{ 
     305If you want to change this HTML document, you probably shouldn't do that 
     306by changing it directly.  Instead, see about changing the calling options 
     307to $class, and/or subclassing $class, 
     308then reconverting this document from the Pod source. 
     309When in doubt, email the author of $class for advice. 
     310See 'perldoc $class' for more info. 
     311}; 
    186312 
    187 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     313} 
    188314 
    189 sub do_link { 
    190   my($self, $token) = @_; 
    191   my $type = $token->attr('type'); 
    192   if(!defined $type) { 
    193     $self->whine("Typeless L!?", $token->attr('start_line')); 
    194   } elsif( $type eq 'pod') { return $self->do_pod_link($token); 
    195   } elsif( $type eq 'url') { return $self->do_url_link($token); 
    196   } elsif( $type eq 'man') { return $self->do_man_link($token); 
    197   } else { 
    198     $self->whine("L of unknown type $type!?", $token->attr('start_line')); 
     315sub do_end { 
     316  my $self = $_[0]; 
     317  print {$self->{'output_fh'}}  $self->html_footer || ''; 
     318  return 1; 
     319} 
     320 
     321# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     322# Normally this would just be a call to _do_middle_main_loop -- but we 
     323#  have to do some elaborate things to emit all the content and then 
     324#  summarize it and output it /before/ the content that it's a summary of. 
     325 
     326sub do_middle { 
     327  my $self = $_[0]; 
     328  return $self->_do_middle_main_loop unless $self->index; 
     329 
     330  if( $self->output_string ) { 
     331    # An efficiency hack 
     332    my $out = $self->output_string; #it's a reference to it 
     333    my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n"; 
     334    $$out .= $sneakytag; 
     335    $self->_do_middle_main_loop; 
     336    $sneakytag = quotemeta($sneakytag); 
     337    my $index = $self->index_as_html(); 
     338    if( $$out =~ s/$sneakytag/$index/s ) { 
     339      # Expected case 
     340      DEBUG and print "Inserted ", length($index), " bytes of index HTML into $out.\n"; 
     341    } else { 
     342      DEBUG and print "Odd, couldn't find where to insert the index in the output!\n"; 
     343      # I don't think this should ever happen. 
     344    } 
     345    return 1; 
    199346  } 
    200   return 'FNORG'; 
     347 
     348  unless( $self->output_fh ) { 
     349    require Carp; 
     350    Carp::confess("Parser object \$p doesn't seem to have any output object!  I don't know how to deal with that."); 
     351  } 
     352 
     353  # If we get here, we're outputting to a FH.  So we need to do some magic. 
     354  # Namely, divert all content to a string, which we output after the index. 
     355  my $fh = $self->output_fh; 
     356  my $content = ''; 
     357  { 
     358    # Our horrible bait and switch: 
     359    $self->output_string( \$content ); 
     360    $self->_do_middle_main_loop; 
     361    $self->abandon_output_string(); 
     362    $self->output_fh($fh); 
     363  } 
     364  print $fh $self->index_as_html(); 
     365  print $fh $content; 
     366 
     367  return 1; 
    201368} 
    202369 
     370########################################################################### 
    203371 
    204 sub do_middle {      # the main work 
     372sub index_as_html { 
    205373  my $self = $_[0]; 
     374  # This is meant to be called AFTER the input document has been parsed! 
     375 
     376  my $points = $self->{'PSHTML_index_points'} || []; 
     377   
     378  @$points > 1 or return qq[<div class='indexgroupEmpty'></div>\n]; 
     379   # There's no point in having a 0-item or 1-item index, I dare say. 
     380   
     381  my(@out) = qq{\n<div class='indexgroup'>}; 
     382  my $level = 0; 
     383 
     384  my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent); 
     385  foreach my $p (@$points, ['head0', '(end)']) { 
     386    ($tagname, $text) = @$p; 
     387    $anchorname = $self->section_escape($text); 
     388    if( $tagname =~ m{^head(\d+)$} ) { 
     389      $target_level = 0 + $1; 
     390    } else {  # must be some kinda list item 
     391      if($previous_tagname =~ m{^head\d+$} ) { 
     392        $target_level = $level + 1; 
     393      } else { 
     394        $target_level = $level;  # no change needed 
     395      } 
     396    } 
     397     
     398    # Get to target_level by opening or closing ULs 
     399    while($level > $target_level) 
     400     { --$level; push @out, ("  " x $level) . "</ul>"; } 
     401    while($level < $target_level) 
     402     { ++$level; push @out, ("  " x ($level-1)) 
     403       . "<ul   class='indexList indexList$level'>"; } 
     404 
     405    $previous_tagname = $tagname; 
     406    next unless $level; 
     407     
     408    $indent = '  '  x $level; 
     409    push @out, sprintf 
     410      "%s<li class='indexItem indexItem%s'><a href='#%s'>%s</a>", 
     411      $indent, $level, $anchorname, esc($text) 
     412    ; 
     413  } 
     414  push @out, "</div>\n"; 
     415  return join "\n", @out; 
     416} 
     417 
     418########################################################################### 
     419 
     420sub _do_middle_main_loop { 
     421  my $self = $_[0]; 
    206422  my $fh = $self->{'output_fh'}; 
     423  my $tagmap = $self->{'Tagmap'}; 
    207424   
    208   my($token, $type, $tagname); 
     425  my($token, $type, $tagname, $linkto, $linktype); 
    209426  my @stack; 
    210427  my $dont_wrap = 0; 
     428 
    211429  while($token = $self->get_token) { 
    212430 
    213431    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
    214432    if( ($type = $token->type) eq 'start' ) { 
    215433      if(($tagname = $token->tagname) eq 'L') { 
    216         esc($type = $self->do_link($token)); # reuse it, why not 
    217         if(defined $type and length $type) { 
    218           print $fh "<a href='$type'>"; 
     434        $linktype = $token->attr('type') || 'insane'; 
     435         
     436        $linkto = $self->do_link($token); 
     437 
     438        if(defined $linkto and length $linkto) { 
     439          esc($linkto); 
     440            #   (Yes, SGML-escaping applies on top of %-escaping! 
     441            #   But it's rarely noticeable in practice.) 
     442          print $fh qq{<a href="$linkto" class="podlink$linktype"\n>}; 
    219443        } else { 
    220444          print $fh "<a>"; # Yes, an 'a' element with no attributes! 
    221445        } 
    222446 
    223447      } elsif ($tagname eq 'item-text' or $tagname =~ m/^head\d$/s) { 
    224         print $fh $self->{'Tagmap'}{$tagname} || next; 
     448        print $fh $tagmap->{$tagname} || next; 
    225449 
    226450        my @to_unget; 
    227451        while(1) { 
    228452          push @to_unget, $self->get_token; 
    229453          last if $to_unget[-1]->is_end 
    230454              and $to_unget[-1]->tagname eq $tagname; 
     455           
     456          # TODO: support for X<...>'s found in here?  (maybe hack into linearize_tokens) 
    231457        } 
     458 
    232459        my $name = $self->linearize_tokens(@to_unget); 
    233460         
    234         if(defined $name) { # ludicrously long, so nevermind 
    235           $name =~ tr/ /_/; 
    236           print $fh "<a name=\"", esc($name), "\"\n>"; 
     461        print $fh "<a "; 
     462        print $fh "class='u' href='#___top' title='click to go to top of document'\n" 
     463         if $tagname =~ m/^head\d$/s; 
     464         
     465        if(defined $name) { 
     466          my $esc = esc(  $self->section_name_tidy( $name ) ); 
     467          print $fh qq[name="$esc"]; 
    237468          DEBUG and print "Linearized ", scalar(@to_unget), 
    238469           " tokens as \"$name\".\n"; 
    239         } else { 
    240           print $fh "<a\n>";  # Yes, an 'a' element with no attributes! 
     470          push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name] 
     471           if $ToIndex{ $tagname }; 
     472            # Obviously, this discards all formatting codes (saving 
     473            #  just their content), but ahwell. 
     474            
     475        } else {  # ludicrously long, so nevermind 
    241476          DEBUG and print "Linearized ", scalar(@to_unget), 
    242477           " tokens, but it was too long, so nevermind.\n"; 
    243478        } 
     479        print $fh "\n>"; 
    244480        $self->unget_token(@to_unget); 
    245481 
    246482      } elsif ($tagname eq 'Data') { 
     
    255491        next; 
    256492        
    257493      } else { 
    258         if( $tagname =~ m/^over-(.+)$/s ) { 
    259           push @stack, $1; 
    260         } elsif( $tagname eq 'Para') { 
    261           $tagname = 'Para_item' if @stack and $stack[-1] eq 'text'; 
     494        if( $tagname =~ m/^over-/s ) { 
     495          push @stack, ''; 
     496        } elsif( $tagname =~ m/^item-/s and @stack and $stack[-1] ) { 
     497          print $fh $stack[-1]; 
     498          $stack[-1] = ''; 
    262499        } 
    263         print $fh $self->{'Tagmap'}{$tagname} || next; 
     500        print $fh $tagmap->{$tagname} || next; 
    264501        ++$dont_wrap if $tagname eq 'Verbatim' or $tagname eq "VerbatimFormatted" 
    265502          or $tagname eq 'X'; 
    266503      } 
     
    268505    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
    269506    } elsif( $type eq 'end' ) { 
    270507      if( ($tagname = $token->tagname) =~ m/^over-/s ) { 
    271         pop @stack; 
    272       } elsif( $tagname eq 'Para' ) { 
    273         $tagname = 'Para_item' if @stack and $stack[-1] eq 'text'; 
     508        if( my $end = pop @stack ) { 
     509          print $fh $end; 
     510        } 
     511      } elsif( $tagname =~ m/^item-/s and @stack) { 
     512        $stack[-1] = $tagmap->{"/$tagname"}; 
     513        if( $tagname eq 'item-text' and defined(my $next = $self->get_token) ) { 
     514          $self->unget_token($next); 
     515          if( $next->type eq 'start' and $next->tagname !~ m/^item-/s ) { 
     516            print $fh $tagmap->{"/item-text"},$tagmap->{"item-body"}; 
     517            $stack[-1] = $tagmap->{"/item-body"}; 
     518          } 
     519        } 
     520        next; 
    274521      } 
    275       print $fh $self->{'Tagmap'}{"/$tagname"} || next; 
     522      print $fh $tagmap->{"/$tagname"} || next; 
    276523      --$dont_wrap if $tagname eq 'Verbatim' or $tagname eq 'X'; 
    277524 
    278525    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     
    286533  return 1; 
    287534} 
    288535 
     536########################################################################### 
     537# 
     538 
     539sub do_link { 
     540  my($self, $token) = @_; 
     541  my $type = $token->attr('type'); 
     542  if(!defined $type) { 
     543    $self->whine("Typeless L!?", $token->attr('start_line')); 
     544  } elsif( $type eq 'pod') { return $self->do_pod_link($token); 
     545  } elsif( $type eq 'url') { return $self->do_url_link($token); 
     546  } elsif( $type eq 'man') { return $self->do_man_link($token); 
     547  } else { 
     548    $self->whine("L of unknown type $type!?", $token->attr('start_line')); 
     549  } 
     550  return 'FNORG'; # should never get called 
     551} 
     552 
    289553# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
    290554 
    291 sub do_beginning { 
    292   my $self = $_[0]; 
     555sub do_url_link { return $_[1]->attr('to') } 
    293556 
    294   my $title = $self->get_short_title(); 
    295   unless($self->content_seen) { 
    296     DEBUG and print "No content seen in search for title.\n"; 
    297     return; 
     557sub do_man_link { return undef } 
     558 # But subclasses are welcome to override this if they have man 
     559 #  pages somewhere URL-accessible. 
     560 
     561 
     562sub do_pod_link { 
     563  # And now things get really messy... 
     564  my($self, $link) = @_; 
     565  my $to = $link->attr('to'); 
     566  my $section = $link->attr('section'); 
     567  return undef unless(  # should never happen 
     568    (defined $to and length $to) or 
     569    (defined $section and length $section) 
     570  ); 
     571 
     572  $section = $self->section_escape($section) 
     573   if defined $section and length($section .= ''); # (stringify) 
     574 
     575  DEBUG and printf "Resolving \"%s\" \"%s\"...\n", 
     576   $to || "(nil)",  $section || "(nil)"; 
     577    
     578  { 
     579    # An early hack: 
     580    my $complete_url = $self->resolve_pod_link_by_table($to, $section); 
     581    if( $complete_url ) { 
     582      DEBUG > 1 and print "resolve_pod_link_by_table(T,S) gives ", 
     583        $complete_url, "\n  (Returning that.)\n"; 
     584      return $complete_url; 
     585    } else { 
     586      DEBUG > 4 and print " resolve_pod_link_by_table(T,S)",  
     587       " didn't return anything interesting.\n"; 
     588    } 
    298589  } 
    299   $self->{'Title'} = $title; 
    300590 
    301   esc($title); 
    302   print {$self->{'output_fh'}} 
    303    "<html><head>\n<title>$title</title>\n</head>\n<body>\n",  
    304    $self->version_tag_comment, 
    305    "<!-- start doc -->\n", 
    306   ; 
    307    # TODO: more configurability there 
     591  if(defined $to and length $to) { 
     592    # Give this routine first hack again 
     593    my $there = $self->resolve_pod_link_by_table($to); 
     594    if(defined $there and length $there) { 
     595      DEBUG > 1 
     596       and print "resolve_pod_link_by_table(T) gives $there\n"; 
     597    } else { 
     598      $there =  
     599        $self->resolve_pod_page_link($to, $section); 
     600         # (I pass it the section value, but I don't see a 
     601         #  particular reason it'd use it.) 
     602      DEBUG > 1 and print "resolve_pod_page_link gives ", $to || "(nil)", "\n"; 
     603      unless( defined $there and length $there ) { 
     604        DEBUG and print "Can't resolve $to\n"; 
     605        return undef; 
     606      } 
     607      # resolve_pod_page_link returning undef is how it 
     608      #  can signal that it gives up on making a link 
     609    } 
     610    $to = $there; 
     611  } 
    308612 
    309   DEBUG and print "Returning from do_beginning...\n"; 
    310   return 1; 
     613  #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n"; 
     614 
     615  my $out = (defined $to and length $to) ? $to : ''; 
     616  $out .= "#" . $section if defined $section and length $section; 
     617   
     618  unless(length $out) { # sanity check 
     619    DEBUG and printf "Oddly, couldn't resolve \"%s\" \"%s\"...\n", 
     620     $to || "(nil)",  $section || "(nil)"; 
     621    return undef; 
     622  } 
     623 
     624  DEBUG and print "Resolved to $out\n"; 
     625  return $out;   
    311626} 
    312627 
    313 sub version_tag_comment { 
    314   my $self = shift; 
    315   return sprintf 
    316    "<!-- generated by %s v%s, using %s v%s, under Perl v%s at %s GMT -->\n", 
    317     # None of the following things should need escaping, I dare say! 
    318     ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(), 
    319     $], scalar(gmtime), 
    320    
     628 
     629# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 
     630 
     631sub section_escape { 
     632  my($self, $section) = @_; 
     633  return $self->section_url_escape( 
     634    $self->section_name_tidy($section) 
     635  ); 
    321636} 
    322637 
     638sub section_name_tidy { 
     639  my($self, $section) = @_; 
     640  $section =~ tr/ /_/; 
     641  $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters 
     642  $section = $self->unicode_escape_url($section); 
     643  $section = '_' unless length $section; 
     644  return $section; 
     645} 
    323646 
    324 sub do_end { 
    325   my $self = $_[0]; 
    326   print {$self->{'output_fh'}} "\n<!-- end doc -->\n</body></html>\n"; 
    327    # TODO: allow for a footer 
    328   return 1; 
     647sub section_url_escape  { shift->general_url_escape(@_) } 
     648sub pagepath_url_escape { shift->general_url_escape(@_) } 
     649 
     650sub general_url_escape { 
     651  my($self, $string) = @_; 
     652  
     653  $string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg; 
     654     # express Unicode things as urlencode(utf(orig)). 
     655   
     656  # A pretty conservative escaping, behoovey even for query components 
     657  #  of a URL (see RFC 2396) 
     658   
     659  $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg; 
     660   # Yes, stipulate the list without a range, so that this can work right on 
     661   #  all charsets that this module happens to run under. 
     662   # Altho, hmm, what about that ord?  Presumably that won't work right 
     663   #  under non-ASCII charsets.  Something should be done 
     664   #  about that, I guess? 
     665   
     666  return $string; 
    329667} 
    330668 
    331 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    332 sub esc { 
    333   if(defined wantarray) { 
    334     if(wantarray) { 
    335       @_ = splice @_; # break aliasing 
    336     } else { 
    337       my $x = shift; 
    338       $x =~ s/([^\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; 
    339       return $x; 
    340     } 
     669#-------------------------------------------------------------------------- 
     670# 
     671# Oh look, a yawning portal to Hell!  Let's play touch football right by it! 
     672# 
     673 
     674sub resolve_pod_page_link { 
     675  # resolve_pod_page_link must return a properly escaped URL 
     676  my $self = shift; 
     677  return $self->batch_mode() 
     678   ? $self->resolve_pod_page_link_batch_mode(@_) 
     679   : $self->resolve_pod_page_link_singleton_mode(@_) 
     680  ; 
     681} 
     682 
     683sub resolve_pod_page_link_singleton_mode { 
     684  my($self, $it) = @_; 
     685  return undef unless defined $it and length $it; 
     686  my $url = $self->pagepath_url_escape($it); 
     687   
     688  $url =~ s{::$}{}s; # probably never comes up anyway 
     689  $url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM? 
     690   
     691  return undef unless length $url; 
     692  return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix; 
     693} 
     694 
     695sub resolve_pod_page_link_batch_mode { 
     696  my($self, $to) = @_; 
     697  DEBUG > 1 and print " During batch mode, resolving $to ...\n"; 
     698  my @path = grep length($_), split m/::/s, $to, -1; 
     699  unless( @path ) { # sanity 
     700    DEBUG and print "Very odd!  Splitting $to gives (nil)!\n"; 
     701    return undef; 
    341702  } 
    342   foreach my $x (@_) { 
    343     # Escape things very cautiously: 
    344     $x =~ s/([^\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; 
    345     # Leave out "- so that "--" won't make it thru in X-generated comments 
    346     #  with text in them. 
     703  $self->batch_mode_rectify_path(\@path); 
     704  my $out = join('/', map $self->pagepath_url_escape($_), @path) 
     705    . $HTML_EXTENSION; 
     706  DEBUG > 1 and print " => $out\n"; 
     707  return $out; 
     708} 
    347709 
    348     # Yes, stipulate the list without a range, so that this can work right on 
    349     #  all charsets that this module happens to run under. 
    350     # Altho, hmm, what about that ord?  Presumably that won't work right 
    351     #  under non-ASCII charsets.  Something should be done about that. 
     710sub batch_mode_rectify_path { 
     711  my($self, $pathbits) = @_; 
     712  my $level = $self->batch_mode_current_level; 
     713  $level--; # how many levels up to go to get to the root 
     714  if($level < 1) { 
     715    unshift @$pathbits, '.'; # just to be pretty 
     716  } else { 
     717    unshift @$pathbits, ('..') x $level; 
    352718  } 
    353   return @_; 
     719  return; 
    354720} 
    355721 
    356722#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    357723 
     724sub resolve_pod_link_by_table { 
     725  # A crazy hack to allow specifying custom L<foo> => URL mappings 
     726 
     727  return unless $_[0]->{'podhtml_LOT'};  # An optimizy shortcut 
     728 
     729  my($self, $to, $section) = @_; 
     730 
     731  # TODO: add a method that actually populates podhtml_LOT from a file? 
     732 
     733  if(defined $section) { 
     734    $to = '' unless defined $to and length $to; 
     735    return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef! 
     736  } else { 
     737    return $self->{'podhtml_LOT'}{$to};            # quite possibly undef! 
     738  } 
     739  return; 
     740} 
     741 
     742########################################################################### 
     743 
    358744sub linearize_tokens {  # self, tokens 
    359745  my $self = shift; 
    360746  my $out = ''; 
     
    362748  my $t; 
    363749  while($t = shift @_) { 
    364750    if(!ref $t or !UNIVERSAL::can($t, 'is_text')) { 
    365       $out .= $t; 
     751      $out .= $t; # a string, or some insane thing 
    366752    } elsif($t->is_text) { 
    367753      $out .= $t->text; 
    368754    } elsif($t->is_start and $t->tag eq 'X') { 
    369       # ignore until the end of this X<...> sequence 
     755      # Ignore until the end of this X<...> sequence: 
    370756      my $x_open = 1; 
    371757      while($x_open) { 
    372758        next if( ($t = shift @_)->is_text ); 
     
    375761      } 
    376762    } 
    377763  } 
    378    
    379   $out =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); 
    380764  return undef if length $out > $Linearization_Limit; 
    381    
    382   $out = $self->unicode_escape_url($out); 
    383   $out = '_' unless length $out; 
    384    
    385765  return $out; 
    386766} 
    387767 
     
    395775} 
    396776 
    397777#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     778sub esc { # a function. 
     779  if(defined wantarray) { 
     780    if(wantarray) { 
     781      @_ = splice @_; # break aliasing 
     782    } else { 
     783      my $x = shift; 
     784      $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; 
     785      return $x; 
     786    } 
     787  } 
     788  foreach my $x (@_) { 
     789    # Escape things very cautiously: 
     790    $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg 
     791     if defined $x; 
     792    # Leave out "- so that "--" won't make it thru in X-generated comments 
     793    #  with text in them. 
    398794 
     795    # Yes, stipulate the list without a range, so that this can work right on 
     796    #  all charsets that this module happens to run under. 
     797    # Altho, hmm, what about that ord?  Presumably that won't work right 
     798    #  under non-ASCII charsets.  Something should be done about that. 
     799  } 
     800  return @_; 
     801} 
     802 
     803#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     804 
    3998051; 
    400806__END__ 
    401807 
    402808=head1 NAME 
    403809 
    404 TODO - TODO 
     810Pod::Simple::HTML - convert Pod to HTML 
    405811 
    406812=head1 SYNOPSIS 
    407813 
    408  TODO 
     814  perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod 
    409815 
    410   perl -MPod::Simple::HTML -e \ 
    411    "exit Pod::Simple::HTML->filter(shift)->errors_seen" \ 
    412    thingy.pod 
    413816 
    414  
    415817=head1 DESCRIPTION 
    416818 
    417 This class is for TODO. 
     819This class is for making an HTML rendering of a Pod document. 
     820 
    418821This is a subclass of L<Pod::Simple::PullParser> and inherits all its 
    419 methods. 
     822methods (and options). 
    420823 
     824Note that if you want to do a batch conversion of a lot of Pod 
     825documents to HTML, you should see the module L<Pod::Simple::HTMLBatch>. 
     826 
     827 
     828 
     829=head1 CALLING FROM THE COMMAND LINE 
     830 
    421831TODO 
    422832 
     833  perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html 
     834 
     835 
     836 
     837=head1 CALLING FROM PERL 
     838 
     839TODO   make a new object, set any options, and use parse_from_file 
     840 
     841 
     842=head1 METHODS 
     843 
     844TODO 
     845all (most?) accessorized methods 
     846 
     847 
     848=head1 SUBCLASSING 
     849 
     850TODO 
     851 
     852 can just set any of:  html_css html_javascript title_prefix 
     853  'html_header_before_title', 
     854  'html_header_after_title', 
     855  'html_footer', 
     856 
     857maybe override do_pod_link 
     858 
     859maybe override do_beginning do_end 
     860 
     861 
     862 
    423863=head1 SEE ALSO 
    424864 
    425 L<Pod::Simple> 
     865L<Pod::Simple>, L<Pod::Simple::HTMLBatch> 
    426866 
     867 
     868TODO: a corpus of sample Pod input and HTML output?  Or common 
     869idioms? 
     870 
     871 
     872 
    427873=head1 COPYRIGHT AND DISCLAIMERS 
    428874 
    429 Copyright (c) 2002 Sean M. Burke.  All rights reserved. 
     875Copyright (c) 2002-2004 Sean M. Burke.  All rights reserved. 
    430876 
    431877This library is free software; you can redistribute it and/or modify it 
    432878under the same terms as Perl itself. 
  • lib/Pod/Simple/BlackBox.pm

     
    525525    DEBUG > 1 and print "Pondering a $para_type paragraph, given the stack: (", 
    526526      $self->_dump_curr_open(), ")\n"; 
    527527     
    528     if($para_type eq '=for') { #////////////////////////////////////////////// 
    529       # Fake it out as a begin/end 
    530       my $target; 
     528    if($para_type eq '=for') { 
     529      next if $self->_ponder_for($para,$curr_open,$paras); 
    531530 
    532       if(grep $_->[1]{'~ignore'}, @$curr_open) { 
    533         DEBUG > 1 and print "Ignoring ignorable =for\n"; 
    534         next; 
    535       } 
     531    } elsif($para_type eq '=begin') { 
     532      next if $self->_ponder_begin($para,$curr_open,$paras); 
    536533 
    537       for(my $i = 2; $i < @$para; ++$i) { 
    538         if($para->[$i] =~ s/^\s*(\S+)\s*//s) { 
    539           $target = $1; 
    540           last; 
    541         } 
    542       } 
    543       unless(defined $target) { 
    544         $self->whine( 
    545           $para->[1]{'start_line'}, 
    546           "=for without a target?" 
    547         ); 
    548         next; 
    549       } 
    550       DEBUG > 1 and 
    551        print "Faking out a =for $target as a =begin $target / =end $target\n"; 
    552        
    553       $para->[0] = 'Data'; 
    554        
    555       unshift @$paras, 
    556         ['=begin', 
    557           {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, 
    558           $target, 
    559         ], 
    560         $para, 
    561         ['=end', 
    562           {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, 
    563           $target, 
    564         ], 
    565       ; 
    566        
    567       next; 
    568        
    569     } elsif($para_type eq '=begin') { #/////////////////////////////////////// 
     534    } elsif($para_type eq '=end') { 
     535      next if $self->_ponder_end($para,$curr_open,$paras); 
    570536 
    571       my $content = join ' ', splice @$para, 2; 
    572       $content =~ s/^\s+//s; 
    573       $content =~ s/\s+$//s; 
    574       unless(length($content)) { 
    575         $self->whine( 
    576           $para->[1]{'start_line'}, 
    577           "=begin without a target?" 
    578         ); 
    579         DEBUG and print "Ignoring targetless =begin\n"; 
    580         next; 
    581       } 
    582        
    583       unless($content =~ m/^\S+$/s) {  # i.e., unless it's one word 
    584         $self->whine( 
    585           $para->[1]{'start_line'}, 
    586           "'=begin' only takes one parameter, not several as in '=begin $content'" 
    587         ); 
    588         DEBUG and print "Ignoring unintelligible =begin $content\n"; 
    589         next; 
    590       } 
    591  
    592  
    593       $para->[1]{'target'} = $content;  # without any ':' 
    594  
    595       $content =~ s/^:!/!:/s; 
    596       my $neg;  # whether this is a negation-match 
    597       $neg = 1        if $content =~ s/^!//s; 
    598       my $to_resolve;  # whether to process formatting codes 
    599       $to_resolve = 1 if $content =~ s/^://s; 
    600        
    601       my $dont_ignore; # whether this target matches us 
    602        
    603       foreach my $target_name ( 
    604         split(',', $content, -1), 
    605         $neg ? () : '*' 
    606       ) { 
    607         DEBUG > 2 and 
    608          print " Considering whether =begin $content matches $target_name\n"; 
    609         next unless $self->{'accept_targets'}{$target_name}; 
    610          
    611         DEBUG > 2 and 
    612          print "  It DOES match the acceptable target $target_name!\n"; 
    613         $to_resolve = 1 
    614           if $self->{'accept_targets'}{$target_name} eq 'force_resolve'; 
    615         $dont_ignore = 1; 
    616         $para->[1]{'target_matching'} = $target_name; 
    617         last; # stop looking at other target names 
    618       } 
    619  
    620       if($neg) { 
    621         if( $dont_ignore ) { 
    622           $dont_ignore = ''; 
    623           delete $para->[1]{'target_matching'}; 
    624           DEBUG > 2 and print " But the leading ! means that this is a NON-match!\n"; 
    625         } else { 
    626           $dont_ignore = 1; 
    627           $para->[1]{'target_matching'} = '!'; 
    628           DEBUG > 2 and print " But the leading ! means that this IS a match!\n"; 
    629         } 
    630       } 
    631  
    632       $para->[0] = '=for';  # Just what we happen to call these, internally 
    633       $para->[1]{'~really'} ||= '=begin'; 
    634       $para->[1]{'~ignore'}   = (! $dont_ignore) || 0; 
    635       $para->[1]{'~resolve'}  = $to_resolve || 0; 
    636  
    637       DEBUG > 1 and print " Making note to ", $dont_ignore ? 'not ' : '', 
    638         "ignore contents of this region\n"; 
    639       DEBUG > 1 and $dont_ignore and print " Making note to treat contents as ", 
    640         ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n"; 
    641       DEBUG > 1 and print " (Stack now: ", $self->_dump_curr_open(), ")\n"; 
    642  
    643       push @$curr_open, $para; 
    644       if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) { 
    645         DEBUG > 1 and print "Ignoring ignorable =begin\n"; 
    646       } else { 
    647         $self->{'content_seen'} ||= 1; 
    648         $self->_handle_element_start(($scratch='for'), $para->[1]); 
    649       } 
    650  
    651       next; 
    652        
    653     } elsif($para_type eq '=end') { #///////////////////////////////////////// 
    654  
    655       my $content = join ' ', splice @$para, 2; 
    656       $content =~ s/^\s+//s; 
    657       $content =~ s/\s+$//s; 
    658       DEBUG and print "Ogling '=end $content' directive\n"; 
    659        
    660       unless(length($content)) { 
    661         $self->whine( 
    662           $para->[1]{'start_line'}, 
    663           "'=end' without a target?" . ( 
    664             ( @$curr_open and $curr_open->[-1][0] eq '=for' ) 
    665             ? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' ) 
    666             : '' 
    667           ) 
    668         ); 
    669         DEBUG and print "Ignoring targetless =end\n"; 
    670         next; 
    671       } 
    672        
    673       unless($content =~ m/^\S+$/) {  # i.e., unless it's one word 
    674         $self->whine( 
    675           $para->[1]{'start_line'}, 
    676           "'=end $content' is invalid.  (Stack: " 
    677           . $self->_dump_curr_open() . ')' 
    678         ); 
    679         DEBUG and print "Ignoring mistargetted =end $content\n"; 
    680         next; 
    681       } 
    682        
    683       unless(@$curr_open and $curr_open->[-1][0] eq '=for') { 
    684         $self->whine( 
    685           $para->[1]{'start_line'}, 
    686           "=end $content without matching =begin.  (Stack: " 
    687           . $self->_dump_curr_open() . ')' 
    688         ); 
    689         DEBUG and print "Ignoring mistargetted =end $content\n"; 
    690         next; 
    691       } 
    692        
    693       unless($content eq $curr_open->[-1][1]{'target'}) { 
    694         $self->whine( 
    695           $para->[1]{'start_line'}, 
    696           "=end $content doesn't match =begin "  
    697           . $curr_open->[-1][1]{'target'} 
    698           . ".  (Stack: " 
    699           . $self->_dump_curr_open() . ')' 
    700         ); 
    701         DEBUG and print "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n"; 
    702         next; 
    703       } 
    704  
    705       # Else it's okay to close... 
    706       if(grep $_->[1]{'~ignore'}, @$curr_open) { 
    707         DEBUG > 1 and print "Not firing any event for this =end $content because in an ignored region\n"; 
    708         # And that may be because of this to-be-closed =for region, or some 
    709         #  other one, but it doesn't matter. 
    710       } else { 
    711         $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'}; 
    712           # what's that for? 
    713          
    714         $self->{'content_seen'} ||= 1; 
    715         $self->_handle_element_end( $scratch = 'for' ); 
    716       } 
    717       DEBUG > 1 and print "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n"; 
    718       pop @$curr_open; 
    719  
    720       next; 
    721        
    722     } elsif($para_type eq '~end') { #///////////////////////////////////////// 
    723       # The virtual end-document signal 
    724        
    725       if(@$curr_open) { # Deal with things left open 
    726         DEBUG and print "Stack is nonempty at end-document: (", 
    727           $self->_dump_curr_open(), ")\n"; 
    728            
    729         DEBUG > 9 and print "Stack: ", pretty($curr_open), "\n"; 
    730         unshift @$paras, $self->_closers_for_all_curr_open; 
    731         # Make sure there is exactly one ~end in the parastack, at the end: 
    732         @$paras = grep $_->[0] ne '~end', @$paras; 
    733         push @$paras, $para, $para; 
    734          # We need two -- once for the next cycle where we 
    735          #  generate errata, and then another to be at the end 
    736          #  when that loop back around to process the errata. 
    737         next; 
    738          
    739       } else { 
    740         DEBUG and print "Okay, stack is empty now.\n"; 
    741       } 
    742        
    743       # Try generating errata section, if applicable 
    744       unless($self->{'~tried_gen_errata'}) { 
    745         $self->{'~tried_gen_errata'} = 1; 
    746         my @extras = $self->_gen_errata(); 
    747         if(@extras) { 
    748           unshift @$paras, @extras; 
    749           DEBUG and print "Generated errata... relooping...\n"; 
    750           next;  # I.e., loop around again to process these fake-o paragraphs 
    751         } 
    752       } 
    753        
    754       splice @$paras; # Well, that's that for this paragraph buffer. 
    755       DEBUG and print "Throwing end-document event.\n"; 
    756  
    757       $self->_handle_element_end( $scratch = 'Document' ); 
    758       next; # Hasta la byebye 
     537    } elsif($para_type eq '~end') { # The virtual end-document signal 
     538      next if $self->_ponder_doc_end($para,$curr_open,$paras); 
    759539    } 
    760540 
    761541 
     
    769549    #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ 
    770550    # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ 
    771551 
    772     if($para_type eq '=pod') { #////////////////////////////////////////////// 
    773       $self->whine( 
    774         $para->[1]{'start_line'}, 
    775         "=pod directives shouldn't be over one line long!  Ignoring all " 
    776          . (@$para - 2) . " lines of content" 
    777       ) if @$para > 3; 
    778       # Content is always ignored. 
    779        
     552    if($para_type eq '=pod') { 
     553      $self->_ponder_pod($para,$curr_open,$paras); 
    780554 
    781     } elsif($para_type eq '=over') { #//////////////////////////////////////// 
    782       next unless @$paras; 
    783       my $list_type; 
     555    } elsif($para_type eq '=over') { 
     556      next if $self->_ponder_over($para,$curr_open,$paras); 
    784557 
    785       if($paras->[0][0] eq '=item') { # most common case 
    786         $list_type = $self->_get_initial_item_type($paras->[0]); 
     558    } elsif($para_type eq '=back') { 
     559      next if $self->_ponder_back($para,$curr_open,$paras); 
    787560 
    788       } elsif($paras->[0][0] eq '=back') { 
    789         # Ignore empty lists.  TODO: make this an option? 
    790         shift @$paras; 
    791         next; 
    792          
    793       } elsif($paras->[0][0] eq '~end') { 
    794         $self->whine( 
    795           $para->[1]{'start_line'}, 
    796           "=over is the last thing in the document?!" 
    797         ); 
    798         next; # But feh, ignore it. 
    799       } else { 
    800         $list_type = 'block'; 
    801       } 
    802       $para->[1]{'~type'} = $list_type; 
    803       push @$curr_open, $para; 
    804        # yes, we reuse the paragraph as a stack item 
    805        
    806       my $content = join ' ', splice @$para, 2; 
    807       my $overness; 
    808       if($content =~ m/^\s*$/s) { 
    809         $para->[1]{'indent'} = 4; 
    810       } elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) { 
    811         no integer; 
    812         $para->[1]{'indent'} = $1; 
    813         if($1 == 0) { 
    814           $self->whine( 
    815             $para->[1]{'start_line'}, 
    816             "Can't have a 0 in =over $content" 
    817           ); 
    818           $para->[1]{'indent'} = 4; 
    819         } 
    820       } else { 
    821         $self->whine( 
    822           $para->[1]{'start_line'}, 
    823           "=over should be: '=over' or '=over positive_number'" 
    824         ); 
    825         $para->[1]{'indent'} = 4; 
    826       } 
    827       DEBUG > 1 and print "=over found of type $list_type\n"; 
    828        
    829       $self->{'content_seen'} ||= 1; 
    830       $self->_handle_element_start(($scratch = 'over-' . $list_type), $para->[1]); 
    831        
    832     } elsif($para_type eq '=back') { #//////////////////////////////////////// 
     561    } else { 
    833562 
    834       # TODO: fire off </item-number> or </item-bullet> or </item-text> ?? 
    835  
    836       my $content = join ' ', splice @$para, 2; 
    837       if($content =~ m/\S/) { 
    838         $self->whine( 
    839           $para->[1]{'start_line'}, 
    840           "=back doesn't take any parameters, but you said =back $content" 
    841         ); 
    842       } 
    843  
    844       if(@$curr_open and $curr_open->[-1][0] eq '=over') { 
    845         DEBUG > 1 and print "=back happily closes matching =over\n"; 
    846         # Expected case: we're closing the most recently opened thing 
    847         #my $over = pop @$curr_open; 
    848         $self->{'content_seen'} ||= 1; 
    849         $self->_handle_element_end( $scratch = 
    850           'over-' . ( (pop @$curr_open)->[1]{'~type'} ) 
    851         ); 
    852       } else { 
    853         DEBUG > 1 and print "=back found without a matching =over.  Stack: (", 
    854             join(', ', map $_->[0], @$curr_open), ").\n"; 
    855         $self->whine( 
    856           $para->[1]{'start_line'}, 
    857           '=back without =over' 
    858         ); 
    859         next; # and ignore it 
    860       } 
    861        
    862     } else { #//////////////////////////////////////////////////////////////// 
    863563      # All non-magical codes!!! 
    864564       
    865565      # Here we start using $para_type for our own twisted purposes, to 
     
    1123823 
    1124824      #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
    1125825      if($para_type eq 'Plain') { 
    1126         DEBUG and print " giving plain treatment...\n"; 
    1127         unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' ) 
    1128           or $para->[1]{'~cooked'} 
    1129         ) { 
    1130           push @$para, 
    1131           @{$self->_make_treelet( 
    1132             join("\n", splice(@$para, 2)), 
    1133             $para->[1]{'start_line'} 
    1134           )}; 
    1135         } 
    1136         # Empty paragraphs don't need a treelet for any reason I can see. 
    1137         # And precooked paragraphs already have a treelet. 
    1138          
     826        $self->_ponder_Plain($para); 
    1139827      } elsif($para_type eq 'Verbatim') { 
    1140         DEBUG and print " giving verbatim treatment...\n"; 
    1141        
    1142         $para->[1]{'xml:space'} = 'preserve'; 
    1143         for($i = 2; $i < @$para; $i++) { 
    1144           foreach my $line ($para->[$i]) { # just for aliasing 
    1145             while( $line =~ 
    1146               # Sort of adapted from Text::Tabs -- yes, it's hardwired in that 
    1147               # tabs are at every EIGHTH column.  For portability, it has to be 
    1148               # one setting everywhere, and 8th wins. 
    1149               s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e 
    1150             ) {} 
    1151  
    1152             # TODO: whinge about (or otherwise treat) unindented or overlong lines 
    1153  
    1154           } 
    1155         } 
    1156          
    1157         # Now the VerbatimFormatted hoodoo... 
    1158         if( $self->{'accept_codes'} and 
    1159             $self->{'accept_codes'}{'VerbatimFormatted'} 
    1160         ) { 
    1161           while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para } 
    1162            # Kill any number of terminal newlines 
    1163           $self->_verbatim_format($para); 
    1164         } else { 
    1165           push @$para, join "\n", splice(@$para, 2) if @$para > 3; 
    1166           $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines 
    1167         } 
    1168          
     828        $self->_ponder_Verbatim($para);         
    1169829      } elsif($para_type eq 'Data') { 
    1170         DEBUG and print " giving data treatment...\n"; 
    1171         $para->[1]{'xml:space'} = 'preserve'; 
    1172         push @$para, join "\n", splice(@$para, 2) if @$para > 3; 
    1173          
     830        $self->_ponder_Data($para); 
    1174831      } else { 
    1175832        die "\$para type is $para_type -- how did that happen?"; 
    1176833        # Shouldn't happen. 
     
    1190847  return; 
    1191848} 
    1192849 
     850########################################################################### 
     851# The sub-ponderers... 
     852 
     853 
     854 
     855sub _ponder_for { 
     856  my ($self,$para,$curr_open,$paras) = @_; 
     857 
     858  # Fake it out as a begin/end 
     859  my $target; 
     860 
     861  if(grep $_->[1]{'~ignore'}, @$curr_open) { 
     862    DEBUG > 1 and print "Ignoring ignorable =for\n"; 
     863    return 1; 
     864  } 
     865 
     866  for(my $i = 2; $i < @$para; ++$i) { 
     867    if($para->[$i] =~ s/^\s*(\S+)\s*//s) { 
     868      $target = $1; 
     869      last; 
     870    } 
     871  } 
     872  unless(defined $target) { 
     873    $self->whine( 
     874      $para->[1]{'start_line'}, 
     875      "=for without a target?" 
     876    ); 
     877    return 1; 
     878  } 
     879  DEBUG > 1 and 
     880   print "Faking out a =for $target as a =begin $target / =end $target\n"; 
     881   
     882  $para->[0] = 'Data'; 
     883   
     884  unshift @$paras, 
     885    ['=begin', 
     886      {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, 
     887      $target, 
     888    ], 
     889    $para, 
     890    ['=end', 
     891      {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, 
     892      $target, 
     893    ], 
     894  ; 
     895   
     896  return 1; 
     897} 
     898 
     899sub _ponder_begin { 
     900  my ($self,$para,$curr_open,$paras) = @_; 
     901  my $content = join ' ', splice @$para, 2; 
     902  $content =~ s/^\s+//s; 
     903  $content =~ s/\s+$//s; 
     904  unless(length($content)) { 
     905    $self->whine( 
     906      $para->[1]{'start_line'}, 
     907      "=begin without a target?" 
     908    ); 
     909    DEBUG and print "Ignoring targetless =begin\n"; 
     910    return 1; 
     911  } 
     912   
     913  my ($target, $title) = $content =~ m/^(\S+)\s*(.*)$/; 
     914  $para->[1]{'title'} = $title if ($title); 
     915  $para->[1]{'target'} = $target;  # without any ':' 
     916  $content = $target; # strip off the title 
     917 
     918  $content =~ s/^:!/!:/s; 
     919  my $neg;  # whether this is a negation-match 
     920  $neg = 1        if $content =~ s/^!//s; 
     921  my $to_resolve;  # whether to process formatting codes 
     922  $to_resolve = 1 if $content =~ s/^://s; 
     923   
     924  my $dont_ignore; # whether this target matches us 
     925   
     926  foreach my $target_name ( 
     927    split(',', $content, -1), 
     928    $neg ? () : '*' 
     929  ) { 
     930    DEBUG > 2 and 
     931     print " Considering whether =begin $content matches $target_name\n"; 
     932    next unless $self->{'accept_targets'}{$target_name}; 
     933     
     934    DEBUG > 2 and 
     935     print "  It DOES match the acceptable target $target_name!\n"; 
     936    $to_resolve = 1 
     937      if $self->{'accept_targets'}{$target_name} eq 'force_resolve'; 
     938    $dont_ignore = 1; 
     939    $para->[1]{'target_matching'} = $target_name; 
     940    last; # stop looking at other target names 
     941  } 
     942 
     943  if($neg) { 
     944    if( $dont_ignore ) { 
     945      $dont_ignore = ''; 
     946      delete $para->[1]{'target_matching'}; 
     947      DEBUG > 2 and print " But the leading ! means that this is a NON-match!\n"; 
     948    } else { 
     949      $dont_ignore = 1; 
     950      $para->[1]{'target_matching'} = '!'; 
     951      DEBUG > 2 and print " But the leading ! means that this IS a match!\n"; 
     952    } 
     953  } 
     954 
     955  $para->[0] = '=for';  # Just what we happen to call these, internally 
     956  $para->[1]{'~really'} ||= '=begin'; 
     957  $para->[1]{'~ignore'}   = (! $dont_ignore) || 0; 
     958  $para->[1]{'~resolve'}  = $to_resolve || 0; 
     959 
     960  DEBUG > 1 and print " Making note to ", $dont_ignore ? 'not ' : '', 
     961    "ignore contents of this region\n"; 
     962  DEBUG > 1 and $dont_ignore and print " Making note to treat contents as ", 
     963    ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n"; 
     964  DEBUG > 1 and print " (Stack now: ", $self->_dump_curr_open(), ")\n"; 
     965 
     966  push @$curr_open, $para; 
     967  if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) { 
     968    DEBUG > 1 and print "Ignoring ignorable =begin\n"; 
     969  } else { 
     970    $self->{'content_seen'} ||= 1; 
     971    $self->_handle_element_start((my $scratch='for'), $para->[1]); 
     972  } 
     973 
     974  return 1; 
     975} 
     976 
     977sub _ponder_end { 
     978  my ($self,$para,$curr_open,$paras) = @_; 
     979  my $content = join ' ', splice @$para, 2; 
     980  $content =~ s/^\s+//s; 
     981  $content =~ s/\s+$//s; 
     982  DEBUG and print "Ogling '=end $content' directive\n"; 
     983   
     984  unless(length($content)) { 
     985    $self->whine( 
     986      $para->[1]{'start_line'}, 
     987      "'=end' without a target?" . ( 
     988        ( @$curr_open and $curr_open->[-1][0] eq '=for' ) 
     989        ? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' ) 
     990        : '' 
     991      ) 
     992    ); 
     993    DEBUG and print "Ignoring targetless =end\n"; 
     994    return 1; 
     995  } 
     996   
     997  unless($content =~ m/^\S+$/) {  # i.e., unless it's one word 
     998    $self->whine( 
     999      $para->[1]{'start_line'}, 
     1000      "'=end $content' is invalid.  (Stack: " 
     1001      . $self->_dump_curr_open() . ')' 
     1002    ); 
     1003    DEBUG and print "Ignoring mistargetted =end $content\n"; 
     1004    return 1; 
     1005  } 
     1006   
     1007  unless(@$curr_open and $curr_open->[-1][0] eq '=for') { 
     1008    $self->whine( 
     1009      $para->[1]{'start_line'}, 
     1010      "=end $content without matching =begin.  (Stack: " 
     1011      . $self->_dump_curr_open() . ')' 
     1012    ); 
     1013    DEBUG and print "Ignoring mistargetted =end $content\n"; 
     1014    return 1; 
     1015  } 
     1016   
     1017  unless($content eq $curr_open->[-1][1]{'target'}) { 
     1018    $self->whine( 
     1019      $para->[1]{'start_line'}, 
     1020      "=end $content doesn't match =begin "  
     1021      . $curr_open->[-1][1]{'target'} 
     1022      . ".  (Stack: " 
     1023      . $self->_dump_curr_open() . ')' 
     1024    ); 
     1025    DEBUG and print "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n"; 
     1026    return 1; 
     1027  } 
     1028 
     1029  # Else it's okay to close... 
     1030  if(grep $_->[1]{'~ignore'}, @$curr_open) { 
     1031    DEBUG > 1 and print "Not firing any event for this =end $content because in an ignored region\n"; 
     1032    # And that may be because of this to-be-closed =for region, or some 
     1033    #  other one, but it doesn't matter. 
     1034  } else { 
     1035    $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'}; 
     1036      # what's that for? 
     1037     
     1038    $self->{'content_seen'} ||= 1; 
     1039    $self->_handle_element_end( my $scratch = 'for' ); 
     1040  } 
     1041  DEBUG > 1 and print "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n"; 
     1042  pop @$curr_open; 
     1043 
     1044  return 1; 
     1045}  
     1046 
     1047sub _ponder_doc_end { 
     1048  my ($self,$para,$curr_open,$paras) = @_; 
     1049  if(@$curr_open) { # Deal with things left open 
     1050    DEBUG and print "Stack is nonempty at end-document: (", 
     1051      $self->_dump_curr_open(), ")\n"; 
     1052       
     1053    DEBUG > 9 and print "Stack: ", pretty($curr_open), "\n"; 
     1054    unshift @$paras, $self->_closers_for_all_curr_open; 
     1055    # Make sure there is exactly one ~end in the parastack, at the end: 
     1056    @$paras = grep $_->[0] ne '~end', @$paras; 
     1057    push @$paras, $para, $para; 
     1058     # We need two -- once for the next cycle where we 
     1059     #  generate errata, and then another to be at the end 
     1060     #  when that loop back around to process the errata. 
     1061    return 1; 
     1062     
     1063  } else { 
     1064    DEBUG and print "Okay, stack is empty now.\n"; 
     1065  } 
     1066   
     1067  # Try generating errata section, if applicable 
     1068  unless($self->{'~tried_gen_errata'}) { 
     1069    $self->{'~tried_gen_errata'} = 1; 
     1070    my @extras = $self->_gen_errata(); 
     1071    if(@extras) { 
     1072      unshift @$paras, @extras; 
     1073      DEBUG and print "Generated errata... relooping...\n"; 
     1074      return 1;  # I.e., loop around again to process these fake-o paragraphs 
     1075    } 
     1076  } 
     1077   
     1078  splice @$paras; # Well, that's that for this paragraph buffer. 
     1079  DEBUG and print "Throwing end-document event.\n"; 
     1080 
     1081  $self->_handle_element_end( my $scratch = 'Document' ); 
     1082  return 1; # Hasta la byebye 
     1083} 
     1084 
     1085sub _ponder_pod { 
     1086  my ($self,$para,$curr_open,$paras) = @_; 
     1087  $self->whine( 
     1088    $para->[1]{'start_line'}, 
     1089    "=pod directives shouldn't be over one line long!  Ignoring all " 
     1090     . (@$para - 2) . " lines of content" 
     1091  ) if @$para > 3; 
     1092  # Content is always ignored. 
     1093  return; 
     1094} 
     1095 
     1096sub _ponder_over { 
     1097  my ($self,$para,$curr_open,$paras) = @_; 
     1098  return 1 unless @$paras; 
     1099  my $list_type; 
     1100 
     1101  if($paras->[0][0] eq '=item') { # most common case 
     1102    $list_type = $self->_get_initial_item_type($paras->[0]); 
     1103 
     1104  } elsif($paras->[0][0] eq '=back') { 
     1105    # Ignore empty lists.  TODO: make this an option? 
     1106    shift @$paras; 
     1107    return 1; 
     1108     
     1109  } elsif($paras->[0][0] eq '~end') { 
     1110    $self->whine( 
     1111      $para->[1]{'start_line'}, 
     1112      "=over is the last thing in the document?!" 
     1113    ); 
     1114    return 1; # But feh, ignore it. 
     1115  } else { 
     1116    $list_type = 'block'; 
     1117  } 
     1118  $para->[1]{'~type'} = $list_type; 
     1119  push @$curr_open, $para; 
     1120   # yes, we reuse the paragraph as a stack item 
     1121   
     1122  my $content = join ' ', splice @$para, 2; 
     1123  my $overness; 
     1124  if($content =~ m/^\s*$/s) { 
     1125    $para->[1]{'indent'} = 4; 
     1126  } elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) { 
     1127    no integer; 
     1128    $para->[1]{'indent'} = $1; 
     1129    if($1 == 0) { 
     1130      $self->whine( 
     1131        $para->[1]{'start_line'}, 
     1132        "Can't have a 0 in =over $content" 
     1133      ); 
     1134      $para->[1]{'indent'} = 4; 
     1135    } 
     1136  } else { 
     1137    $self->whine( 
     1138      $para->[1]{'start_line'}, 
     1139      "=over should be: '=over' or '=over positive_number'" 
     1140    ); 
     1141    $para->[1]{'indent'} = 4; 
     1142  } 
     1143  DEBUG > 1 and print "=over found of type $list_type\n"; 
     1144   
     1145  $self->{'content_seen'} ||= 1; 
     1146  $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]); 
     1147 
     1148  return; 
     1149} 
     1150       
     1151sub _ponder_back { 
     1152  my ($self,$para,$curr_open,$paras) = @_; 
     1153  # TODO: fire off </item-number> or </item-bullet> or </item-text> ?? 
     1154 
     1155  my $content = join ' ', splice @$para, 2; 
     1156  if($content =~ m/\S/) { 
     1157    $self->whine( 
     1158      $para->[1]{'start_line'}, 
     1159      "=back doesn't take any parameters, but you said =back $content" 
     1160    ); 
     1161  } 
     1162 
     1163  if(@$curr_open and $curr_open->[-1][0] eq '=over') { 
     1164    DEBUG > 1 and print "=back happily closes matching =over\n"; 
     1165    # Expected case: we're closing the most recently opened thing 
     1166    #my $over = pop @$curr_open; 
     1167    $self->{'content_seen'} ||= 1; 
     1168    $self->_handle_element_end( my $scratch = 
     1169      'over-' . ( (pop @$curr_open)->[1]{'~type'} ) 
     1170    ); 
     1171  } else { 
     1172    DEBUG > 1 and print "=back found without a matching =over.  Stack: (", 
     1173        join(', ', map $_->[0], @$curr_open), ").\n"; 
     1174    $self->whine( 
     1175      $para->[1]{'start_line'}, 
     1176      '=back without =over' 
     1177    ); 
     1178    return 1; # and ignore it 
     1179  } 
     1180} 
     1181 
     1182sub _ponder_item { 
     1183  my ($self,$para,$curr_open,$paras) = @_; 
     1184  my $over; 
     1185  unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') { 
     1186    $self->whine( 
     1187      $para->[1]{'start_line'}, 
     1188      "'=item' outside of any '=over'" 
     1189    ); 
     1190    unshift @$paras, 
     1191      ['=over', {'start_line' => $para->[1]{'start_line'}}, ''], 
     1192      $para 
     1193    ; 
     1194    return 1; 
     1195  } 
     1196   
     1197   
     1198  my $over_type = $over->[1]{'~type'}; 
     1199   
     1200  if(!$over_type) { 
     1201    # Shouldn't happen1 
     1202    die "Typeless over in stack, starting at line " 
     1203     . $over->[1]{'start_line'}; 
     1204 
     1205  } elsif($over_type eq 'block') { 
     1206    unless($curr_open->[-1][1]{'~bitched_about'}) { 
     1207      $curr_open->[-1][1]{'~bitched_about'} = 1; 
     1208      $self->whine( 
     1209        $curr_open->[-1][1]{'start_line'}, 
     1210        "You can't have =items (as at line " 
     1211        . $para->[1]{'start_line'} 
     1212        . ") unless the first thing after the =over is an =item" 
     1213      ); 
     1214    } 
     1215    # Just turn it into a paragraph and reconsider it 
     1216    $para->[0] = '~Para'; 
     1217    unshift @$paras, $para; 
     1218    return 1; 
     1219 
     1220  } elsif($over_type eq 'text') { 
     1221    my $item_type = $self->_get_item_type($para); 
     1222      # That kills the content of the item if it's a number or bullet. 
     1223    DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; 
     1224     
     1225    if($item_type eq 'text') { 
     1226      # Nothing special needs doing for 'text' 
     1227    } elsif($item_type eq 'number' or $item_type eq 'bullet') { 
     1228      die "Unknown item type $item_type" 
     1229       unless $item_type eq 'number' or $item_type eq 'bullet'; 
     1230      # Undo our clobbering: 
     1231      push @$para, $para->[1]{'~orig_content'}; 
     1232      delete $para->[1]{'number'}; 
     1233       # Only a PROPER item-number element is allowed 
     1234       #  to have a number attribute. 
     1235    } else { 
     1236      die "Unhandled item type $item_type"; # should never happen 
     1237    } 
     1238     
     1239    # =item-text thingies don't need any assimilation, it seems. 
     1240 
     1241  } elsif($over_type eq 'number') { 
     1242    my $item_type = $self->_get_item_type($para); 
     1243      # That kills the content of the item if it's a number or bullet. 
     1244    DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; 
     1245     
     1246    my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; 
     1247     
     1248    if($item_type eq 'bullet') { 
     1249      # Hm, it's not numeric.  Correct for this. 
     1250      $para->[1]{'number'} = $expected_value; 
     1251      $self->whine( 
     1252        $para->[1]{'start_line'}, 
     1253        "Expected '=item $expected_value'" 
     1254      ); 
     1255      push @$para, $para->[1]{'~orig_content'}; 
     1256        # restore the bullet, blocking the assimilation of next para 
     1257 
     1258    } elsif($item_type eq 'text') { 
     1259      # Hm, it's not numeric.  Correct for this. 
     1260      $para->[1]{'number'} = $expected_value; 
     1261      $self->whine( 
     1262        $para->[1]{'start_line'}, 
     1263        "Expected '=item $expected_value'" 
     1264      ); 
     1265      # Text content will still be there and will block next ~Para 
     1266 
     1267    } elsif($item_type ne 'number') { 
     1268      die "Unknown item type $item_type"; # should never happen 
     1269 
     1270    } elsif($expected_value == $para->[1]{'number'}) { 
     1271      DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n"; 
     1272       
     1273    } else { 
     1274      DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'}, 
     1275       " instead of the expected value of $expected_value\n"; 
     1276      $self->whine( 
     1277        $para->[1]{'start_line'}, 
     1278        "You have '=item " . $para->[1]{'number'} . 
     1279        "' instead of the expected '=item $expected_value'" 
     1280      ); 
     1281      $para->[1]{'number'} = $expected_value;  # correcting!! 
     1282    } 
     1283       
     1284    if(@$para == 2) { 
     1285      # For the cases where we /didn't/ push to @$para 
     1286      if($paras->[0][0] eq '~Para') { 
     1287        DEBUG and print "Assimilating following ~Para content into $over_type item\n"; 
     1288        push @$para, splice @{shift @$paras},2; 
     1289      } else { 
     1290        DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; 
     1291        push @$para, '';  # Just so it's not contentless 
     1292      } 
     1293    } 
     1294 
     1295 
     1296  } elsif($over_type eq 'bullet') { 
     1297    my $item_type = $self->_get_item_type($para); 
     1298      # That kills the content of the item if it's a number or bullet. 
     1299    DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; 
     1300     
     1301    if($item_type eq 'bullet') { 
     1302      # as expected! 
     1303 
     1304      if( $para->[1]{'~_freaky_para_hack'} ) { 
     1305        DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n"; 
     1306        push @$para, delete $para->[1]{'~_freaky_para_hack'}; 
     1307      } 
     1308 
     1309    } elsif($item_type eq 'number') { 
     1310      $self->whine( 
     1311        $para->[1]{'start_line'}, 
     1312        "Expected '=item *'" 
     1313      ); 
     1314      push @$para, $para->[1]{'~orig_content'}; 
     1315       # and block assimilation of the next paragraph 
     1316      delete $para->[1]{'number'}; 
     1317       # Only a PROPER item-number element is allowed 
     1318       #  to have a number attribute. 
     1319    } elsif($item_type eq 'text') { 
     1320      $self->whine( 
     1321        $para->[1]{'start_line'}, 
     1322        "Expected '=item *'" 
     1323      ); 
     1324       # But doesn't need processing.  But it'll block assimilation 
     1325       #  of the next para. 
     1326    } else { 
     1327      die "Unhandled item type $item_type"; # should never happen 
     1328    } 
     1329 
     1330    if(@$para == 2) { 
     1331      # For the cases where we /didn't/ push to @$para 
     1332      if($paras->[0][0] eq '~Para') { 
     1333        DEBUG and print "Assimilating following ~Para content into $over_type item\n"; 
     1334        push @$para, splice @{shift @$paras},2; 
     1335      } else { 
     1336        DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; 
     1337        push @$para, '';  # Just so it's not contentless 
     1338      } 
     1339    } 
     1340 
     1341  } else { 
     1342    die "Unhandled =over type \"$over_type\"?"; 
     1343    # Shouldn't happen! 
     1344  } 
     1345  $para->[0] .= '-' . $over_type; 
     1346 
     1347  return; 
     1348} 
     1349 
     1350sub _ponder_Plain { 
     1351  my ($self,$para) = @_; 
     1352  DEBUG and print " giving plain treatment...\n"; 
     1353  unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' ) 
     1354    or $para->[1]{'~cooked'} 
     1355  ) { 
     1356    push @$para, 
     1357    @{$self->_make_treelet( 
     1358      join("\n", splice(@$para, 2)), 
     1359      $para->[1]{'start_line'} 
     1360    )}; 
     1361  } 
     1362  # Empty paragraphs don't need a treelet for any reason I can see. 
     1363  # And precooked paragraphs already have a treelet. 
     1364  return; 
     1365} 
     1366 
     1367sub _ponder_Verbatim { 
     1368  my ($self,$para) = @_; 
     1369  DEBUG and print " giving verbatim treatment...\n"; 
     1370 
     1371  $para->[1]{'xml:space'} = 'preserve'; 
     1372  for(my $i = 2; $i < @$para; $i++) { 
     1373    foreach my $line ($para->[$i]) { # just for aliasing 
     1374      while( $line =~ 
     1375        # Sort of adapted from Text::Tabs -- yes, it's hardwired in that 
     1376        # tabs are at every EIGHTH column.  For portability, it has to be 
     1377        # one setting everywhere, and 8th wins. 
     1378        s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e 
     1379      ) {} 
     1380 
     1381      # TODO: whinge about (or otherwise treat) unindented or overlong lines 
     1382 
     1383    } 
     1384  } 
     1385   
     1386  # Now the VerbatimFormatted hoodoo... 
     1387  if( $self->{'accept_codes'} and 
     1388      $self->{'accept_codes'}{'VerbatimFormatted'} 
     1389  ) { 
     1390    while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para } 
     1391     # Kill any number of terminal newlines 
     1392    $self->_verbatim_format($para); 
     1393  } elsif ($self->{'codes_in_verbatim'}) { 
     1394    push @$para, 
     1395    @{$self->_make_treelet( 
     1396      join("\n", splice(@$para, 2)), 
     1397      $para->[1]{'start_line'}, $para->[1]{'xml:space'} 
     1398    )}; 
     1399    $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines 
     1400  } else { 
     1401    push @$para, join "\n", splice(@$para, 2) if @$para > 3; 
     1402    $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines 
     1403  } 
     1404  return; 
     1405} 
     1406 
     1407sub _ponder_Data { 
     1408  my ($self,$para) = @_; 
     1409  DEBUG and print " giving data treatment...\n"; 
     1410  $para->[1]{'xml:space'} = 'preserve'; 
     1411  push @$para, join "\n", splice(@$para, 2) if @$para > 3; 
     1412  return; 
     1413} 
     1414 
     1415 
     1416 
     1417 
     1418########################################################################### 
     1419 
    11931420sub _traverse_treelet_bit {  # for use only by the routine above 
    11941421  my($self, $name) = splice @_,0,2; 
    11951422 
     
    13821609  #            "!" 
    13831610  #       ] 
    13841611   
    1385   my($self, $para, $start_line) = @_; 
     1612  my($self, $para, $start_line, $preserve_space) = @_; 
     1613   
    13861614  my $treelet = ['~Top', {'start_line' => $start_line},]; 
    13871615   
    1388   $para =~ s/\s+/ /g; # collapse and trim all whitespace first. 
    1389   $para =~ s/ $//g; 
    1390   $para =~ s/^ //g; 
     1616  unless ($preserve_space || $self->{'preserve_whitespace'}) { 
     1617    $para =~ s/\.  /\.\xA0 /g if $self->{'fullstop_space_harden'}; 
    13911618   
     1619    $para =~ s/\s+/ /g; # collapse and trim all whitespace first. 
     1620    $para =~ s/ $//; 
     1621    $para =~ s/^ //; 
     1622  } 
     1623   
    13921624  # Only apparent problem the above code is that N<<  >> turns into 
    13931625  # N<< >>.  But then, word wrapping does that too!  So don't do that! 
    13941626   
     
    13961628  my @lineage = ($treelet); 
    13971629 
    13981630  DEBUG > 4 and print "Paragraph:\n$para\n\n"; 
    1399    
    1400   while($para =~  # Here begins our frightening tokenizer RE. 
     1631  
     1632  # Here begins our frightening tokenizer RE.  The following regex matches 
     1633  # text in four main parts: 
     1634  # 
     1635  #  * Start-codes.  The first alternative matches C< or C<<, the latter 
     1636  #    followed by some whitespace.  $1 will hold the entire start code 
     1637  #    (including any space following a multiple-angle-bracket delimiter), 
     1638  #    and $2 will hold only the additional brackets past the first in a 
     1639  #    multiple-bracket delimiter.  length($2) + 1 will be the number of 
     1640  #    closing brackets we have to find. 
     1641  # 
     1642  #  * Closing brackets.  Match some amount of whitespace followed by 
     1643  #    multiple close brackets.  The logic to see if this closes anything 
     1644  #    is down below.  Note that in order to parse C<<  >> correctly, we 
     1645  #    have to use look-behind (?<=\s\s), since the match of the starting 
     1646  #    code will have consumed the whitespace. 
     1647  # 
     1648  #  * A single closing bracket, to close a simple code like C<>. 
     1649  # 
     1650  #  * Something that isn't a start or end code.  We have to be careful 
     1651  #    about accepting whitespace, since perlpodspec says that any whitespace 
     1652  #    before a multiple-bracket closing delimiter should be ignored. 
     1653  # 
     1654  while($para =~ 
    14011655    m/\G 
    14021656      (?: 
    1403         ([A-Z]<(<+\ )?) # that's $1 and $2 for both kinds of start-codes 
     1657        # Match starting codes, including the whitespace following a 
     1658        # multiple-delimiter start code.  $1 gets the whole start code and 
     1659        # $2 gets all but one of the <s in the multiple-bracket case. 
     1660        ([A-Z]<(?:(<+)\s+)?) 
    14041661        | 
    1405         (\ >{2,})       # $3: end-codes of the type " >>", " >>>", etc. 
     1662        # Match multiple-bracket end codes.  $3 gets the whitespace that 
     1663        # should be discarded before an end bracket but kept in other cases 
     1664        # and $4 gets the end brackets themselves. 
     1665        (\s+|(?<=\s\s))(>{2,}) 
    14061666        | 
    1407         (\ ?>)          # $4: simple end-codes 
     1667        (\s?>)          # $5: simple end-codes 
    14081668        | 
    1409         (               # $5: stuff containing no start-codes or end-codes 
     1669        (               # $6: stuff containing no start-codes or end-codes 
    14101670          (?: 
    1411             [^A-Z\ >]+ 
     1671            [^A-Z\s>] 
    14121672            | 
    14131673            (?: 
    14141674              [A-Z](?!<) 
    14151675            ) 
    14161676            | 
     1677            # whitespace is ok, but we don't want to eat the whitespace before 
     1678            # a multiple-bracket end code. 
     1679            # NOTE: we may still have problems with e.g. S<<    >> 
    14171680            (?: 
    1418               \ (?!>) 
     1681              \s(?!\s*>{2,}) 
    14191682            ) 
    14201683          )+ 
    14211684        ) 
     
    14261689    if(defined $1) { 
    14271690      if(defined $2) { 
    14281691        DEBUG > 3 and print "Found complex start-text code \"$1\"\n"; 
    1429         push @stack, length($1) - 1;  
     1692        push @stack, length($2) + 1;  
    14301693          # length of the necessary complex end-code string 
    14311694      } else { 
    14321695        DEBUG > 3 and print "Found simple start-text code \"$1\"\n"; 
     
    14351698      push @lineage, [ substr($1,0,1), {}, ];  # new node object 
    14361699      push @{ $lineage[-2] }, $lineage[-1]; 
    14371700       
    1438     } elsif(defined $3) { 
    1439       DEBUG > 3 and print "Found apparent complex end-text code \"$3\"\n"; 
     1701    } elsif(defined $4) { 
     1702      DEBUG > 3 and print "Found apparent complex end-text code \"$3$4\"\n"; 
    14401703      # This is where it gets messy... 
    14411704      if(! @stack) { 
    14421705        # We saw " >>>>" but needed nothing.  This is ALL just stuff then. 
    14431706        DEBUG > 4 and print " But it's really just stuff.\n"; 
    1444         push @{ $lineage[-1] }, $3; 
     1707        push @{ $lineage[-1] }, $3, $4; 
    14451708        next; 
    14461709      } elsif(!$stack[-1]) { 
    14471710        # We saw " >>>>" but needed only ">".  Back pos up. 
    14481711        DEBUG > 4 and print " And that's more than we needed to close simple.\n"; 
    1449         push @{ $lineage[-1] }, ' '; # That was a for-real space, too. 
    1450         pos($para) = pos($para) - length($3) + 2; 
    1451       } elsif($stack[-1] == length($3)) { 
     1712        push @{ $lineage[-1] }, $3; # That was a for-real space, too. 
     1713        pos($para) = pos($para) - length($4) + 1; 
     1714      } elsif($stack[-1] == length($4)) { 
    14521715        # We found " >>>>", and it was exactly what we needed.  Commonest case. 
    14531716        DEBUG > 4 and print " And that's exactly what we needed to close complex.\n"; 
    1454       } elsif($stack[-1] < length($3)) { 
     1717      } elsif($stack[-1] < length($4)) { 
    14551718        # We saw " >>>>" but needed only " >>".  Back pos up. 
    14561719        DEBUG > 4 and print " And that's more than we needed to close complex.\n"; 
    1457         pos($para) = pos($para) - length($3) + $stack[-1]; 
     1720        pos($para) = pos($para) - length($4) + $stack[-1]; 
    14581721      } else { 
    14591722        # We saw " >>>>" but needed " >>>>>>".  So this is all just stuff! 
    14601723        DEBUG > 4 and print " But it's really just stuff, because we needed more.\n"; 
    1461         push @{ $lineage[-1] }, $3; 
     1724        push @{ $lineage[-1] }, $3, $4; 
    14621725        next; 
    14631726      } 
    14641727      #print "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n"; 
    1465        
     1728 
    14661729      push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; 
    14671730      # Keep the element from being childless 
    14681731       
    14691732      pop @stack; 
    14701733      pop @lineage; 
    14711734       
    1472     } elsif(defined $4) { 
     1735    } elsif(defined $5) { 
    14731736      DEBUG > 3 and print "Found apparent simple end-text code \"$4\"\n"; 
    14741737 
    14751738      if(@stack and ! $stack[-1]) { 
    14761739        # We're indeed expecting a simple end-code 
    14771740        DEBUG > 4 and print " It's indeed an end-code.\n"; 
    14781741 
    1479         if(length($4) == 2) { # There was a space there: " >" 
     1742        if(length($5) == 2) { # There was a space there: " >" 
    14801743          push @{ $lineage[-1] }, ' '; 
    14811744        } elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element 
    14821745          push @{ $lineage[-1] }, ''; # keep it from being really childless 
     
    14861749        pop @lineage; 
    14871750      } else { 
    14881751        DEBUG > 4 and print " It's just stuff.\n"; 
    1489         push @{ $lineage[-1] }, $4; 
     1752        push @{ $lineage[-1] }, $5; 
    14901753      } 
    14911754 
    1492     } elsif(defined $5) { 
    1493       DEBUG > 3 and print "Found stuff \"$5\"\n"; 
    1494       push @{ $lineage[-1] }, $5; 
     1755    } elsif(defined $6) { 
     1756      DEBUG > 3 and print "Found stuff \"$6\"\n"; 
     1757      push @{ $lineage[-1] }, $6; 
    14951758       
    14961759    } else { 
    14971760      # should never ever ever ever happen 
     
    16341897} 
    16351898 
    16361899#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 
     1900 
     1901# A rather unsubtle method of blowing away all the state information 
     1902# from a parser object so it can be reused. Provided as a utility for 
     1903# backward compatibilty in Pod::Man, etc. but not recommended for 
     1904# general use. 
     1905 
     1906sub reinit { 
     1907  my $self = shift; 
     1908  foreach (qw(source_dead source_filename doc_has_started 
     1909start_of_pod_block content_seen last_was_blank paras curr_open 
     1910line_count pod_para_count in_pod ~tried_gen_errata errata errors_seen 
     1911Title)) { 
     1912 
     1913    delete $self->{$_}; 
     1914  } 
     1915} 
     1916 
     1917#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 
    163719181; 
    16381919 
  • lib/Pod/Escapes.pm

     
    11 
    22require 5; 
    33#                        The documentation is at the end. 
    4 # Time-stamp: "2002-08-27 19:58:02 MDT" 
     4# Time-stamp: "2004-05-07 15:31:25 ADT" 
    55package Pod::Escapes; 
    66require Exporter; 
    77@ISA = ('Exporter'); 
    8 $VERSION = '1.03'; 
     8$VERSION = '1.04'; 
    99@EXPORT_OK = qw( 
    1010  %Code2USASCII 
    1111  %Name2character 
     
    4444  # Convert to decimal: 
    4545  if($in =~ m/^(0[0-7]*)$/s ) { 
    4646    $in = oct $in; 
    47   } elsif($in =~ m/^0x([0-9a-fA-F]+)$/s ) { 
     47  } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) { 
    4848    $in = hex $1; 
    4949  } # else it's decimal, or named 
    5050 
     
    8686  # Convert to decimal: 
    8787  if($in =~ m/^(0[0-7]*)$/s ) { 
    8888    $in = oct $in; 
    89   } elsif($in =~ m/^0x([0-9a-fA-F]+)$/s ) { 
     89  } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) { 
    9090    $in = hex $1; 
    9191  } # else it's decimal, or named 
    9292 
     
    649649 
    650650=head1 COPYRIGHT AND DISCLAIMERS 
    651651 
    652 Copyright (c) 2001 Sean M. Burke.  All rights reserved. 
     652Copyright (c) 2001-2004 Sean M. Burke.  All rights reserved. 
    653653 
    654654This library is free software; you can redistribute it and/or modify 
    655655it under the same terms as Perl itself. 
     
    685685  xhtml-lat1.ent 
    686686  xhtml-special.ent 
    687687)) { 
    688   open(IN, "<$dir$file") or die "can't read-open $dir$file: $!"; 
     688  open(IN, "<", "$dir$file") or die "can't read-open $dir$file: $!"; 
    689689  print "Reading $file...\n"; 
    690690  while(<IN>) { 
    691691    if(m/<!ENTITY\s+(\S+)\s+"&#([^;]+);">/) { 
  • (a) /dev/null vs. (b) lib/Pod/Simple/Progress.pm

    a b  
     1 
     2require 5; 
     3package Pod::Simple::Progress; 
     4$VERSION = "1.01"; 
     5use strict; 
     6 
     7# Objects of this class are used for noting progress of an 
     8#  operation every so often.  Messages delivered more often than that 
     9#  are suppressed. 
     10# 
     11# There's actually nothing in here that's specific to Pod processing; 
     12#  but it's ad-hoc enough that I'm not willing to give it a name that 
     13#  implies that it's generally useful, like "IO::Progress" or something. 
     14# 
     15# -- sburke 
     16# 
     17#-------------------------------------------------------------------------- 
     18 
     19sub new { 
     20  my($class,$delay) = @_; 
     21  my $self = bless {'quiet_until' => 1},  ref($class) || $class; 
     22  $self->to(*STDOUT{IO}); 
     23  $self->delay(defined($delay) ? $delay : 5); 
     24  return $self; 
     25} 
     26 
     27sub copy {  
     28  my $orig = shift; 
     29  bless {%$orig, 'quiet_until' => 1}, ref($orig); 
     30} 
     31#-------------------------------------------------------------------------- 
     32 
     33sub reach { 
     34  my($self, $point, $note) = @_; 
     35  if( (my $now = time) >= $self->{'quiet_until'}) { 
     36    my $goal; 
     37    my    $to = $self->{'to'}; 
     38    print $to join('', 
     39      ($self->{'quiet_until'} == 1) ? () : '... ', 
     40      (defined $point) ? ( 
     41        '#', 
     42        ($goal = $self->{'goal'}) ? ( 
     43          ' ' x (length($goal) - length($point)), 
     44          $point, '/', $goal, 
     45        ) : $point, 
     46        $note ? ': ' : (), 
     47      ) : (), 
     48      $note || '', 
     49      "\n" 
     50    ); 
     51    $self->{'quiet_until'} = $now + $self->{'delay'}; 
     52  } 
     53  return $self; 
     54} 
     55 
     56#-------------------------------------------------------------------------- 
     57 
     58sub done { 
     59  my($self, $note) = @_; 
     60  $self->{'quiet_until'} = 1; 
     61  return $self->reach( undef, $note ); 
     62} 
     63 
     64#-------------------------------------------------------------------------- 
     65# Simple accessors: 
     66 
     67sub delay { 
     68  return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] } 
     69sub goal { 
     70  return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] } 
     71sub to   { 
     72  return $_[0]{'to'   } if @_ == 1; $_[0]{'to'   } = $_[1]; return $_[0] } 
     73 
     74#-------------------------------------------------------------------------- 
     75 
     76unless(caller) { # Simple self-test: 
     77  my $p = __PACKAGE__->new->goal(5); 
     78  $p->reach(1, "Primus!"); 
     79  sleep 1; 
     80  $p->reach(2, "Secundus!"); 
     81  sleep 3; 
     82  $p->reach(3, "Tertius!"); 
     83  sleep 5; 
     84  $p->reach(4); 
     85  $p->reach(5, "Quintus!"); 
     86  sleep 1; 
     87  $p->done("All done"); 
     88} 
     89 
     90#-------------------------------------------------------------------------- 
     911; 
     92__END__ 
     93 
  • (a) /dev/null vs. (b) lib/Pod/Simple/Search.pm

    a b  
     1 
     2require 5.005; 
     3package Pod::Simple::Search; 
     4use strict; 
     5 
     6use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY); 
     7$VERSION = 3.04;   ## Current version of this package 
     8 
     9BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; }   # set DEBUG level 
     10use Carp (); 
     11 
     12$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; 
     13  # flag to occasionally sleep for $SLEEPY - 1 seconds. 
     14 
     15$MAX_VERSION_WITHIN ||= 60; 
     16 
     17############################################################################# 
     18 
     19#use diagnostics; 
     20use File::Spec (); 
     21use File::Basename qw( basename ); 
     22use Config (); 
     23use Cwd qw( cwd ); 
     24 
     25#========================================================================== 
     26__PACKAGE__->_accessorize(  # Make my dumb accessor methods 
     27 'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob', 
     28 'limit_re', 'shadows', 'verbose', 'name2path', 'path2name',  
     29); 
     30#========================================================================== 
     31 
     32sub new { 
     33  my $class = shift; 
     34  my $self = bless {}, ref($class) || $class; 
     35  $self->init; 
     36  return $self; 
     37} 
     38 
     39sub init { 
     40  my $self = shift; 
     41  $self->inc(1); 
     42  $self->verbose(DEBUG); 
     43  return $self; 
     44} 
     45 
     46#-------------------------------------------------------------------------- 
     47 
     48sub survey { 
     49  my($self, @search_dirs) = @_; 
     50  $self = $self->new unless ref $self; # tolerate being a class method 
     51 
     52  $self->_expand_inc( \@search_dirs ); 
     53 
     54 
     55  $self->{'_scan_count'} = 0; 
     56  $self->{'_dirs_visited'} = {}; 
     57  $self->path2name( {} ); 
     58  $self->name2path( {} ); 
     59  $self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'}; 
     60  my $cwd = cwd(); 
     61  my $verbose  = $self->verbose; 
     62  local $_; # don't clobber the caller's $_ ! 
     63 
     64  foreach my $try (@search_dirs) { 
     65    unless( File::Spec->file_name_is_absolute($try) ) { 
     66      # make path absolute 
     67      $try = File::Spec->catfile( $cwd ,$try); 
     68    } 
     69    # simplify path 
     70    $try =  File::Spec->canonpath($try); 
     71 
     72    my $start_in; 
     73    my $modname_prefix; 
     74    if($self->{'dir_prefix'}) { 
     75      $start_in = File::Spec->catdir( 
     76        $try, 
     77        grep length($_), split '[\\/:]+', $self->{'dir_prefix'} 
     78      ); 
     79      $modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}]; 
     80      $verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ", 
     81        "giving $start_in (= @$modname_prefix)\n"; 
     82    } else { 
     83      $start_in = $try; 
     84    } 
     85 
     86    if( $self->{'_dirs_visited'}{$start_in} ) { 
     87      $verbose and print "Directory '$start_in' already seen, skipping.\n"; 
     88      next; 
     89    } else { 
     90      $self->{'_dirs_visited'}{$start_in} = 1; 
     91    } 
     92   
     93    unless(-e $start_in) { 
     94      $verbose and print "Skipping non-existent $start_in\n"; 
     95      next; 
     96    } 
     97 
     98    my $closure = $self->_make_search_callback; 
     99     
     100    if(-d $start_in) { 
     101      # Normal case: 
     102      $verbose and print "Beginning excursion under $start_in\n"; 
     103      $self->_recurse_dir( $start_in, $closure, $modname_prefix ); 
     104      $verbose and print "Back from excursion under $start_in\n\n"; 
     105         
     106    } elsif(-f _) { 
     107      # A excursion consisting of just one file! 
     108      $_ = basename($start_in); 
     109      $verbose and print "Pondering $start_in ($_)\n"; 
     110      $closure->($start_in, $_, 0, []); 
     111         
     112    } else { 
     113      $verbose and print "Skipping mysterious $start_in\n"; 
     114    } 
     115  } 
     116  $self->progress and $self->progress->done( 
     117   "Noted $$self{'_scan_count'} Pod files total"); 
     118 
     119  return unless defined wantarray; # void 
     120  return $self->name2path unless wantarray; # scalar 
     121  return $self->name2path, $self->path2name; # list 
     122} 
     123 
     124 
     125#========================================================================== 
     126sub _make_search_callback { 
     127  my $self = $_[0]; 
     128 
     129  # Put the options in variables, for easy access 
     130  my(  $laborious, $verbose, $shadows, $limit_re, $callback, $progress,$path2name,$name2path) = 
     131    map scalar($self->$_()), 
     132     qw(laborious   verbose   shadows   limit_re   callback   progress  path2name  name2path); 
     133 
     134  my($file, $shortname, $isdir, $modname_bits); 
     135  return sub { 
     136    ($file, $shortname, $isdir, $modname_bits) = @_; 
     137 
     138    if($isdir) { # this never gets called on the startdir itself, just subdirs 
     139 
     140      if( $self->{'_dirs_visited'}{$file} ) { 
     141        $verbose and print "Directory '$file' already seen, skipping.\n"; 
     142        return 'PRUNE'; 
     143      } 
     144 
     145      print "Looking in dir $file\n" if $verbose; 
     146 
     147      unless ($laborious) { # $laborious overrides pruning 
     148        if( m/^(\d+\.[\d_]{3,})\z/s 
     149             and do { my $x = $1; $x =~ tr/_//d; $x != $] } 
     150           ) { 
     151          $verbose and print "Perl $] version mismatch on $_, skipping.\n"; 
     152          return 'PRUNE'; 
     153        } 
     154 
     155        if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) { 
     156          $verbose and print "$_ is a well-named module subdir.  Looking....\n"; 
     157        } else { 
     158          $verbose and print "$_ is a fishy directory name.  Skipping.\n"; 
     159          return 'PRUNE'; 
     160        } 
     161      } # end unless $laborious 
     162 
     163      $self->{'_dirs_visited'}{$file} = 1; 
     164      return; # (not pruning); 
     165    } 
     166 
     167       
     168    # Make sure it's a file even worth even considering 
     169    if($laborious) { 
     170      unless( 
     171        m/\.(pod|pm|plx?)\z/i || -x _ and -T _ 
     172         # Note that the cheapest operation (the RE) is run first. 
     173      ) { 
     174        $verbose > 1 and print " Brushing off uninteresting $file\n"; 
     175        return; 
     176      } 
     177    } else { 
     178      unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) { 
     179        $verbose > 1 and print " Brushing off oddly-named $file\n"; 
     180        return; 
     181      } 
     182    } 
     183 
     184    $verbose and print "Considering item $file\n"; 
     185    my $name = $self->_path2modname( $file, $shortname, $modname_bits ); 
     186    $verbose > 0.01 and print " Nominating $file as $name\n"; 
     187         
     188    if($limit_re and $name !~ m/$limit_re/i) { 
     189      $verbose and print "Shunning $name as not matching $limit_re\n"; 
     190      return; 
     191    } 
     192 
     193    if( !$shadows and $name2path->{$name} ) { 
     194      $verbose and print "Not worth considering $file ", 
     195        "-- already saw $name as ", 
     196        join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n"; 
     197      return; 
     198    } 
     199         
     200    # Put off until as late as possible the expense of 
     201    #  actually reading the file: 
     202    if( m/\.pod\z/is ) { 
     203      # just assume it has pod, okay? 
     204    } else { 
     205      $progress and $progress->reach($self->{'_scan_count'}, "Scanning $file"); 
     206      return unless $self->contains_pod( $file ); 
     207    } 
     208    ++ $self->{'_scan_count'}; 
     209 
     210    # Or finally take note of it: 
     211    if( $name2path->{$name} ) { 
     212      $verbose and print 
     213       "Duplicate POD found (shadowing?): $name ($file)\n", 
     214       "    Already seen in ", 
     215       join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n"; 
     216    } else { 
     217      $name2path->{$name} = $file; # Noting just the first occurrence 
     218    } 
     219    $verbose and print "  Noting $name = $file\n"; 
     220    if( $callback ) { 
     221      local $_ = $_; # insulate from changes, just in case 
     222      $callback->($file, $name); 
     223    } 
     224    $path2name->{$file} = $name; 
     225    return; 
     226  } 
     227} 
     228 
     229#========================================================================== 
     230 
     231sub _path2modname { 
     232  my($self, $file, $shortname, $modname_bits) = @_; 
     233 
     234  # this code simplifies the POD name for Perl modules: 
     235  # * remove "site_perl" 
     236  # * remove e.g. "i586-linux" (from 'archname') 
     237  # * remove e.g. 5.00503 
     238  # * remove pod/ if followed by perl*.pod (e.g. in pod/perlfunc.pod) 
     239  # * dig into the file for case-preserved name if not already mixed case 
     240 
     241  my @m = @$modname_bits; 
     242  my $x; 
     243  my $verbose = $self->verbose; 
     244 
     245  # Shaving off leading naughty-bits 
     246  while(@m 
     247    and defined($x = lc( $m[0] )) 
     248    and(  $x eq 'site_perl' 
     249       or($x eq 'pod' and @m == 1 and $shortname =~ m{^perl.*\.pod$}s ) 
     250       or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?}  # if looks like a vernum 
     251       or $x eq lc( $Config::Config{'archname'} ) 
     252  )) { shift @m } 
     253 
     254  my $name = join '::', @m, $shortname; 
     255  $self->_simplify_base($name); 
     256 
     257  # On VMS, case-preserved document names can't be constructed from 
     258  # filenames, so try to extract them from the "=head1 NAME" tag in the 
     259  # file instead. 
     260  if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) { 
     261      open PODFILE, "<" ,"$file" or die "_path2modname: Can't open $file: $!"; 
     262      my $in_pod = 0; 
     263      my $in_name = 0; 
     264      my $line; 
     265      while ($line = <PODFILE>) { 
     266        chomp $line; 
     267        $in_pod = 1 if ($line =~ m/^=\w/); 
     268        $in_pod = 0 if ($line =~ m/^=cut/); 
     269        next unless $in_pod;         # skip non-pod text 
     270        next if ($line =~ m/^\s*\z/);           # and blank lines 
     271        next if ($in_pod && ($line =~ m/^X</)); # and commands 
     272        if ($in_name) { 
     273          if ($line =~ m/(\w+::)?(\w+)/) { 
     274            # substitute case-preserved version of name 
     275            my $podname = $2; 
     276            my $prefix = $1 || ''; 
     277            $verbose and print "Attempting case restore of '$name' from '$prefix$podname'\n"; 
     278            unless ($name =~ s/$prefix$podname/$prefix$podname/i) { 
     279              $verbose and print "Attempting case restore of '$name' from '$podname'\n"; 
     280              $name =~ s/$podname/$podname/i; 
     281            } 
     282            last; 
     283          } 
     284        } 
     285        $in_name = 1 if ($line =~ m/^=head1 NAME/); 
     286    } 
     287    close PODFILE; 
     288  } 
     289 
     290  return $name; 
     291} 
     292 
     293#========================================================================== 
     294 
     295sub _recurse_dir { 
     296  my($self, $startdir, $callback, $modname_bits) = @_; 
     297 
     298  my $maxdepth = $self->{'fs_recursion_maxdepth'} || 10; 
     299  my $verbose = $self->verbose; 
     300 
     301  my $here_string = File::Spec->curdir; 
     302  my $up_string   = File::Spec->updir; 
     303  $modname_bits ||= []; 
     304 
     305  my $recursor; 
     306  $recursor = sub { 
     307    my($dir_long, $dir_bare) = @_; 
     308    if( @$modname_bits >= 10 ) { 
     309      $verbose and print "Too deep! [@$modname_bits]\n"; 
     310      return; 
     311    } 
     312 
     313    unless(-d $dir_long) { 
     314      $verbose > 2 and print "But it's not a dir! $dir_long\n"; 
     315      return; 
     316    } 
     317    unless( opendir(INDIR, $dir_long) ) { 
     318      $verbose > 2 and print "Can't opendir $dir_long : $!\n"; 
     319      closedir(INDIR); 
     320      return 
     321    } 
     322    my @items = sort readdir(INDIR); 
     323    closedir(INDIR); 
     324 
     325    push @$modname_bits, $dir_bare unless $dir_bare eq ''; 
     326 
     327    my $i_full; 
     328    foreach my $i (@items) { 
     329      next if $i eq $here_string or $i eq $up_string or $i eq ''; 
     330      $i_full = File::Spec->catfile( $dir_long, $i ); 
     331 
     332      if(!-r $i_full) { 
     333        $verbose and print "Skipping unreadable $i_full\n"; 
     334        
     335      } elsif(-f $i_full) { 
     336        $_ = $i; 
     337        $callback->(          $i_full, $i, 0, $modname_bits ); 
     338 
     339      } elsif(-d _) { 
     340        $i =~ s/\.DIR\z//i if $^O eq 'VMS'; 
     341        $_ = $i; 
     342        my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || ''; 
     343 
     344        if($rv eq 'PRUNE') { 
     345          $verbose > 1 and print "OK, pruning"; 
     346        } else { 
     347          # Otherwise, recurse into it 
     348          $recursor->( File::Spec->catdir($dir_long, $i) , $i); 
     349        } 
     350      } else { 
     351        $verbose > 1 and print "Skipping oddity $i_full\n"; 
     352      } 
     353    } 
     354    pop @$modname_bits; 
     355    return; 
     356  };; 
     357 
     358  local $_; 
     359  $recursor->($startdir, ''); 
     360 
     361  undef $recursor;  # allow it to be GC'd 
     362 
     363  return;   
     364} 
     365 
     366 
     367#========================================================================== 
     368 
     369sub run { 
     370  # A function, useful in one-liners 
     371 
     372  my $self = __PACKAGE__->new; 
     373  $self->limit_glob($ARGV[0]) if @ARGV; 
     374  $self->callback( sub { 
     375    my($file, $name) = @_; 
     376    my $version = ''; 
     377      
     378    # Yes, I know we won't catch the version in like a File/Thing.pm 
     379    #  if we see File/Thing.pod first.  That's just the way the 
     380    #  cookie crumbles.  -- SMB 
     381      
     382    if($file =~ m/\.pod$/i) { 
     383      # Don't bother looking for $VERSION in .pod files 
     384      DEBUG and print "Not looking for \$VERSION in .pod $file\n"; 
     385    } elsif( !open(INPOD, "<", $file) ) { 
     386      DEBUG and print "Couldn't open $file: $!\n"; 
     387      close(INPOD); 
     388    } else { 
     389      # Sane case: file is readable 
     390      my $lines = 0; 
     391      while(<INPOD>) { 
     392        last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity 
     393        if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) { 
     394          DEBUG and print "Found version line (#$lines): $_"; 
     395          s/\s*\#.*//s; 
     396          s/\;\s*$//s; 
     397          s/\s+$//s; 
     398          s/\t+/ /s; # nix tabs 
     399          # Optimize the most common cases: 
     400          $_ = "v$1" 
     401            if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s 
     402             # like in $VERSION = "3.14159"; 
     403             or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s 
     404             # like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/); 
     405          ; 
     406            
     407          # Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/) 
     408          $_ = sprintf("v%d.%s", 
     409            map {s/_//g; $_} 
     410              $1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part 
     411           if m{\$Name:\s*([^\$]+)\$}s  
     412          ; 
     413          $version = $_; 
     414          DEBUG and print "Noting $version as version\n"; 
     415          last; 
     416        } 
     417      } 
     418      close(INPOD); 
     419    } 
     420    print "$name\t$version\t$file\n"; 
     421    return; 
     422    # End of callback! 
     423  }); 
     424 
     425  $self->survey; 
     426} 
     427 
     428#========================================================================== 
     429 
     430sub simplify_name { 
     431  my($self, $str) = @_; 
     432     
     433  # Remove all path components 
     434  #                             XXX Why not just use basename()? -- SMB 
     435 
     436  if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s } 
     437  else                { $str =~ s{^.*/+}{}s } 
     438   
     439  $self->_simplify_base($str); 
     440  return $str; 
     441} 
     442 
     443#========================================================================== 
     444 
     445sub _simplify_base {   # Internal method only 
     446 
     447  # strip Perl's own extensions 
     448  $_[1] =~ s/\.(pod|pm|plx?)\z//i; 
     449 
     450  # strip meaningless extensions on Win32 and OS/2 
     451  $_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i; 
     452 
     453  # strip meaningless extensions on VMS 
     454  $_[1] =~ s/\.(com)\z//i if $^O eq 'VMS'; 
     455 
     456  return; 
     457} 
     458 
     459#========================================================================== 
     460 
     461sub _expand_inc { 
     462  my($self, $search_dirs) = @_; 
     463   
     464  return unless $self->{'inc'}; 
     465 
     466  if ($^O eq 'MacOS') { 
     467    push @$search_dirs, 
     468      grep $_ ne File::Spec->curdir, $self->_mac_whammy(@INC); 
     469  # Any other OSs need custom handling here? 
     470  } else { 
     471    push @$search_dirs, grep $_ ne File::Spec->curdir,  @INC; 
     472  } 
     473 
     474  $self->{'laborious'} = 0;   # Since inc said to use INC 
     475  return; 
     476} 
     477 
     478#========================================================================== 
     479 
     480sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS 
     481  my @them; 
     482  (undef,@them) = @_; 
     483  for $_ (@them) { 
     484    if ( $_ eq '.' ) { 
     485      $_ = ':'; 
     486    } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) { 
     487      $_ = ':'. $_; 
     488    } else { 
     489      $_ =~ s|^\./|:|; 
     490    } 
     491  } 
     492  return @them; 
     493} 
     494 
     495#========================================================================== 
     496 
     497sub _limit_glob_to_limit_re { 
     498  my $self = $_[0]; 
     499  my $limit_glob = $self->{'limit_glob'} || return; 
     500 
     501  my $limit_re = '^' . quotemeta($limit_glob) . '$'; 
     502  $limit_re =~ s/\\\?/./g;    # glob "?" => "." 
     503  $limit_re =~ s/\\\*/.*?/g;  # glob "*" => ".*?" 
     504  $limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => "" 
     505 
     506  $self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n"; 
     507 
     508  # A common optimization: 
     509  if(!exists($self->{'dir_prefix'}) 
     510    and $limit_glob =~ m/^(?:\w+\:\:)+/s  # like "File::*" or "File::Thing*" 
     511    # Optimize for sane and common cases (but not things like "*::File") 
     512  ) { 
     513    $self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg; 
     514    $self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n"; 
     515  } 
     516 
     517  return $limit_re; 
     518} 
     519 
     520#========================================================================== 
     521 
     522# contribution mostly from Tim Jenness <t.jenness@jach.hawaii.edu> 
     523 
     524sub find { 
     525  my($self, $pod, @search_dirs) = @_; 
     526  $self = $self->new unless ref $self; # tolerate being a class method 
     527 
     528  # Check usage 
     529  Carp::carp 'Usage: \$self->find($podname, ...)' 
     530   unless defined $pod and length $pod; 
     531 
     532  my $verbose = $self->verbose; 
     533 
     534  # Split on :: and then join the name together using File::Spec 
     535  my @parts = split /::/, $pod; 
     536  $verbose and print "Chomping {$pod} => {@parts}\n"; 
     537 
     538  #@search_dirs = File::Spec->curdir unless @search_dirs; 
     539   
     540  if( $self->inc ) { 
     541    if( $^O eq 'MacOS' ) { 
     542      push @search_dirs, $self->_mac_whammy(@INC); 
     543    } else { 
     544      push @search_dirs,                    @INC; 
     545    } 
     546 
     547    # Add location of pod documentation for perl man pages (eg perlfunc) 
     548    # This is a pod directory in the private install tree 
     549    #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'}, 
     550    #                                   'pod'); 
     551    #push (@search_dirs, $perlpoddir) 
     552    #  if -d $perlpoddir; 
     553 
     554    # Add location of binaries such as pod2text: 
     555    push @search_dirs, $Config::Config{'scriptdir'}; 
     556     # and if that's undef or q{} or nonexistent, we just ignore it later 
     557  } 
     558 
     559  my %seen_dir; 
     560 Dir: 
     561  foreach my $dir ( @search_dirs ) { 
     562    next unless defined $dir and length $dir; 
     563    next if $seen_dir{$dir}; 
     564    $seen_dir{$dir} = 1; 
     565    unless(-d $dir) { 
     566      print "Directory $dir does not exist\n" if $verbose; 
     567      next Dir; 
     568    } 
     569 
     570    print "Looking in directory $dir\n" if $verbose; 
     571    my $fullname = File::Spec->catfile( $dir, @parts ); 
     572    print "Filename is now $fullname\n" if $verbose; 
     573 
     574    foreach my $ext ('', '.pod', '.pm', '.pl') {   # possible extensions 
     575      my $fullext = $fullname . $ext; 
     576      if( -f $fullext  and  $self->contains_pod( $fullext ) ){ 
     577        print "FOUND: $fullext\n" if $verbose; 
     578        return $fullext; 
     579      } 
     580    } 
     581    my $subdir = File::Spec->catdir($dir,'pod'); 
     582    if(-d $subdir) {  # slip in the ./pod dir too 
     583      $verbose and print "Noticing $subdir and stopping there...\n"; 
     584      $dir = $subdir; 
     585      redo Dir; 
     586    } 
     587  } 
     588 
     589  return undef; 
     590} 
     591 
     592#========================================================================== 
     593 
     594sub contains_pod { 
     595  my($self, $file) = @_; 
     596  my $verbose = $self->{'verbose'}; 
     597 
     598  # check for one line of POD 
     599  $verbose > 1 and print " Scanning $file for pod...\n"; 
     600  unless( open(MAYBEPOD,"<", "$file") ) { 
     601    print "Error: $file is unreadable: $!\n"; 
     602    return undef; 
     603  } 
     604 
     605  sleep($SLEEPY - 1) if $SLEEPY; 
     606   # avoid totally hogging the processor on OSs with poor process control 
     607   
     608  local $_; 
     609  while( <MAYBEPOD> ) { 
     610    if(m/^=(head\d|pod|over|item)\b/s) { 
     611      close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting"; 
     612      chomp; 
     613      $verbose > 1 and print "  Found some pod ($_) in $file\n"; 
     614      return 1; 
     615    } 
     616  } 
     617  close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting"; 
     618  $verbose > 1 and print "  No POD in $file, skipping.\n"; 
     619  return 0; 
     620} 
     621 
     622#========================================================================== 
     623 
     624sub _accessorize {  # A simple-minded method-maker 
     625  shift; 
     626  no strict 'refs'; 
     627  foreach my $attrname (@_) { 
     628    *{caller() . '::' . $attrname} = sub { 
     629      use strict; 
     630      $Carp::CarpLevel = 1,  Carp::croak( 
     631       "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)" 
     632      ) unless (@_ == 1 or @_ == 2) and ref $_[0]; 
     633 
     634      # Read access: 
     635      return $_[0]->{$attrname} if @_ == 1; 
     636 
     637      # Write access: 
     638      $_[0]->{$attrname} = $_[1]; 
     639      return $_[0]; # RETURNS MYSELF! 
     640    }; 
     641  } 
     642  # Ya know, they say accessories make the ensemble! 
     643  return; 
     644} 
     645 
     646#========================================================================== 
     647sub _state_as_string { 
     648  my $self = $_[0]; 
     649  return '' unless ref $self; 
     650  my @out = "{\n  # State of $self ...\n"; 
     651  foreach my $k (sort keys %$self) { 
     652    push @out, "  ", _esc($k), " => ", _esc($self->{$k}), ",\n"; 
     653  } 
     654  push @out, "}\n"; 
     655  my $x = join '', @out; 
     656  $x =~ s/^/#/mg; 
     657  return $x; 
     658} 
     659 
     660sub _esc { 
     661  my $in = $_[0]; 
     662  return 'undef' unless defined $in; 
     663  $in =~ 
     664    s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> 
     665     <'\\x'.(unpack("H2",$1))>eg; 
     666  return qq{"$in"}; 
     667} 
     668 
     669#========================================================================== 
     670 
     671run() unless caller;  # run if "perl whatever/Search.pm" 
     672 
     6731; 
     674 
     675#========================================================================== 
     676 
     677__END__ 
     678 
     679 
     680=head1 NAME 
     681 
     682Pod::Simple::Search - find POD documents in directory trees 
     683 
     684=head1 SYNOPSIS 
     685 
     686  use Pod::Simple::Search; 
     687  my $name2path = Pod::Simple::Search->new->limit_glob('LWP::*')->survey; 
     688  print "Looky see what I found: ", 
     689    join(' ', sort keys %$name2path), "\n"; 
     690 
     691  print "LWPUA docs = ", 
     692    Pod::Simple::Search->new->find('LWP::UserAgent') || "?", 
     693    "\n"; 
     694 
     695=head1 DESCRIPTION 
     696 
     697B<Pod::Simple::Search> is a class that you use for running searches 
     698for Pod files.  An object of this class has several attributes 
     699(mostly options for controlling search options), and some methods 
     700for searching based on those attributes. 
     701 
     702The way to use this class is to make a new object of this class, 
     703set any options, and then call one of the search options 
     704(probably C<survey> or C<find>).  The sections below discuss the 
     705syntaxes for doing all that. 
     706 
     707 
     708=head1 CONSTRUCTOR 
     709 
     710This class provides the one constructor, called C<new>. 
     711It takes no parameters: 
     712 
     713  use Pod::Simple::Search; 
     714  my $search = Pod::Simple::Search->new; 
     715 
     716=head1 ACCESSORS 
     717 
     718This class defines several methods for setting (and, occasionally, 
     719reading) the contents of an object. With two exceptions (discussed at 
     720the end of this section), these attributes are just for controlling the 
     721way searches are carried out. 
     722 
     723Note that each of these return C<$self> when you call them as 
     724C<< $self->I<whatever(value)> >>.  That's so that you can chain 
     725together set-attribute calls like this: 
     726 
     727  my $name2path = 
     728    Pod::Simple::Search->new 
     729    -> inc(0) -> verbose(1) -> callback(\&blab) 
     730    ->survey(@there); 
     731 
     732...which works exactly as if you'd done this: 
     733 
     734  my $search = Pod::Simple::Search->new; 
     735  $search->inc(0); 
     736  $search->verbose(1); 
     737  $search->callback(\&blab); 
     738  my $name2path = $search->survey(@there); 
     739 
     740=over 
     741 
     742=item $search->inc( I<true-or-false> ); 
     743 
     744This attribute, if set to a true value, means that searches should 
     745implicitly add perl's I<@INC> paths. This 
     746automatically considers paths specified in the C<PERL5LIB> environment 
     747as this is prepended to I<@INC> by the Perl interpreter itself. 
     748This attribute's default value is B<TRUE>.  If you want to search 
     749only specific directories, set $self->inc(0) before calling 
     750$inc->survey or $inc->find. 
     751 
     752 
     753=item $search->verbose( I<nonnegative-number> ); 
     754 
     755This attribute, if set to a nonzero positive value, will make searches output 
     756(via C<warn>) notes about what they're doing as they do it. 
     757This option may be useful for debugging a pod-related module. 
     758This attribute's default value is zero, meaning that no C<warn> messages 
     759are produced.  (Setting verbose to 1 turns on some messages, and setting 
     760it to 2 turns on even more messages, i.e., makes the following search(es) 
     761even more verbose than 1 would make them.) 
     762 
     763 
     764=item $search->limit_glob( I<some-glob-string> ); 
     765 
     766This option means that you want to limit the results just to items whose 
     767podnames match the given glob/wildcard expression. For example, you 
     768might limit your search to just "LWP::*", to search only for modules 
     769starting with "LWP::*" (but not including the module "LWP" itself); or 
     770you might limit your search to "LW*" to see only modules whose (full) 
     771names begin with "LW"; or you might search for "*Find*" to search for 
     772all modules with "Find" somewhere in their full name. (You can also use 
     773"?" in a glob expression; so "DB?" will match "DBI" and "DBD".) 
     774 
     775 
     776=item $search->callback( I<\&some_routine> ); 
     777 
     778This attribute means that every time this search sees a matching 
     779Pod file, it should call this callback routine.  The routine is called 
     780with two parameters: the current file's filespec, and its pod name. 
     781(For example: C<("/etc/perljunk/File/Crunk.pm", "File::Crunk")> would 
     782be in C<@_>.) 
     783 
     784The callback routine's return value is not used for anything. 
     785 
     786This attribute's default value is false, meaning that no callback 
     787is called. 
     788 
     789=item $search->laborious( I<true-or-false> ); 
     790 
     791Unless you set this attribute to a true value, Pod::Search will  
     792apply Perl-specific heuristics to find the correct module PODs quickly. 
     793This attribute's default value is false.  You won't normally need 
     794to set this to true. 
     795 
     796Specifically: Turning on this option will disable the heuristics for 
     797seeing only files with Perl-like extensions, omitting subdirectories 
     798that are numeric but do I<not> match the current Perl interpreter's 
     799version ID, suppressing F<site_perl> as a module hierarchy name, etc. 
     800 
     801 
     802=item $search->shadows( I<true-or-false> ); 
     803 
     804Unless you set this attribute to a true value, Pod::Simple::Search will 
     805consider only the first file of a given modulename as it looks thru the 
     806specified directories; that is, with this option off, if 
     807Pod::Simple::Search has seen a C<somepathdir/Foo/Bar.pm> already in this 
     808search, then it won't bother looking at a C<somelaterpathdir/Foo/Bar.pm> 
     809later on in that search, because that file is merely a "shadow". But if 
     810you turn on C<< $self->shadows(1) >>, then these "shadow" files are 
     811inspected too, and are noted in the pathname2podname return hash. 
     812 
     813This attribute's default value is false; and normally you won't 
     814need to turn it on. 
     815 
     816 
     817=item $search->limit_re( I<some-regxp> ); 
     818 
     819Setting this attribute (to a value that's a regexp) means that you want 
     820to limit the results just to items whose podnames match the given 
     821regexp. Normally this option is not needed, and the more efficient 
     822C<limit_glob> attribute is used instead. 
     823 
     824 
     825=item $search->dir_prefix( I<some-string-value> ); 
     826 
     827Setting this attribute to a string value means that the searches should 
     828begin in the specified subdirectory name (like "Pod" or "File::Find", 
     829also expressable as "File/Find"). For example, the search option 
     830C<< $search->limit_glob("File::Find::R*") >> 
     831is the same as the combination of the search options 
     832C<< $search->limit_re("^File::Find::R") -> dir_prefix("File::Find") >>. 
     833 
     834Normally you don't need to know about the C<dir_prefix> option, but I 
     835include it in case it might prove useful for someone somewhere. 
     836 
     837(Implementationally, searching with limit_glob ends up setting limit_re 
     838and usually dir_prefix.) 
     839 
     840 
     841=item $search->progress( I<some-progress-object> ); 
     842 
     843If you set a value for this attribute, the value is expected 
     844to be an object (probably of a class that you define) that has a  
     845C<reach> method and a C<done> method.  This is meant for reporting 
     846progress during the search, if you don't want to use a simple 
     847callback. 
     848 
     849Normally you don't need to know about the C<progress> option, but I 
     850include it in case it might prove useful for someone somewhere. 
     851 
     852While a search is in progress, the progress object's C<reach> and 
     853C<done> methods are called like this: 
     854 
     855  # Every time a file is being scanned for pod: 
     856  $progress->reach($count, "Scanning $file");   ++$count; 
     857 
     858  # And then at the end of the search: 
     859  $progress->done("Noted $count Pod files total"); 
     860 
     861Internally, we often set this to an object of class 
     862Pod::Simple::Progress.  That class is probably undocumented, 
     863but you may wish to look at its source. 
     864 
     865 
     866=item $name2path = $self->name2path; 
     867 
     868This attribute is not a search parameter, but is used to report the 
     869result of C<survey> method, as discussed in the next section. 
     870 
     871=item $path2name = $self->path2name; 
     872 
     873This attribute is not a search parameter, but is used to report the 
     874result of C<survey> method, as discussed in the next section. 
     875 
     876=back 
     877 
     878=head1 MAIN SEARCH METHODS 
     879 
     880Once you've actually set any options you want (if any), you can go 
     881ahead and use the following methods to search for Pod files 
     882in particular ways. 
     883 
     884 
     885=head2 C<< $search->survey( @directories ) >> 
     886 
     887The method C<survey> searches for POD documents in a given set of 
     888files and/or directories.  This runs the search according to the various 
     889options set by the accessors above.  (For example, if the C<inc> attribute 
     890is on, as it is by default, then the perl @INC directories are implicitly 
     891added to the list of directories (if any) that you specify.) 
     892 
     893The return value of C<survey> is two hashes: 
     894 
     895=over 
     896 
     897=item C<name2path> 
     898 
     899A hash that maps from each pod-name to the filespec (like 
     900"Stuff::Thing" => "/whatever/plib/Stuff/Thing.pm") 
     901 
     902=item C<path2name> 
     903 
     904A hash that maps from each Pod filespec to its pod-name (like 
     905"/whatever/plib/Stuff/Thing.pm" => "Stuff::Thing") 
     906 
     907=back 
     908 
     909Besides saving these hashes as the hashref attributes 
     910C<name2path> and C<path2name>, calling this function also returns 
     911these hashrefs.  In list context, the return value of 
     912C<< $search->survey >> is the list C<(\%name2path, \%path2name)>. 
     913In scalar context, the return value is C<\%name2path>. 
     914Or you can just call this in void context. 
     915 
     916Regardless of calling context, calling C<survey> saves 
     917its results in its C<name2path> and C<path2name> attributes. 
     918 
     919E.g., when searching in F<$HOME/perl5lib>, the file 
     920F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>, 
     921whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be 
     922I<Myclass::Subclass>. The name information can be used for POD 
     923translators. 
     924 
     925Only text files containing at least one valid POD command are found. 
     926 
     927In verbose mode, a warning is printed if shadows are found (i.e., more 
     928than one POD file with the same POD name is found, e.g. F<CPAN.pm> in 
     929different directories).  This usually indicates duplicate occurrences of 
     930modules in the I<@INC> search path, which is occasionally inadvertent 
     931(but is often simply a case of a user's path dir having a more recent 
     932version than the system's general path dirs in general.) 
     933 
     934The options to this argument is a list of either directories that are 
     935searched recursively, or files.  (Usually you wouldn't specify files, 
     936but just dirs.)  Or you can just specify an empty-list, as in 
     937$name2path; with the 
     938C<inc> option on, as it is by default, teh 
     939 
     940The POD names of files are the plain basenames with any Perl-like 
     941extension (.pm, .pl, .pod) stripped, and path separators replaced by 
     942C<::>'s. 
     943 
     944Calling Pod::Simple::Search->search(...) is short for 
     945Pod::Simple::Search->new->search(...).  That is, a throwaway object 
     946with default attribute values is used. 
     947 
     948 
     949=head2 C<< $search->simplify_name( $str ) >> 
     950 
     951The method B<simplify_name> is equivalent to B<basename>, but also 
     952strips Perl-like extensions (.pm, .pl, .pod) and extensions like 
     953F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively. 
     954 
     955 
     956=head2 C<< $search->find( $pod ) >> 
     957 
     958=head2 C<< $search->find( $pod, @search_dirs ) >> 
     959 
     960Returns the location of a Pod file, given a Pod/module/script name 
     961(like "Foo::Bar" or "perlvar" or "perldoc"), and an idea of 
     962what files/directories to look in. 
     963It searches according to the various options set by the accessors above. 
     964(For example, if the C<inc> attribute is on, as it is by default, then 
     965the perl @INC directories are implicitly added to the list of 
     966directories (if any) that you specify.) 
     967 
     968This returns the full path of the first occurrence to the file. 
     969Package names (eg 'A::B') are automatically converted to directory 
     970names in the selected directory.  Additionally, '.pm', '.pl' and '.pod' 
     971are automatically appended to the search as required. 
     972(So, for example, under Unix, "A::B" is converted to "somedir/A/B.pm", 
     973"somedir/A/B.pod", or "somedir/A/B.pl", as appropriate.) 
     974 
     975If no such Pod file is found, this method returns undef. 
     976 
     977If any of the given search directories contains a F<pod/> subdirectory, 
     978then it is searched.  (That's how we manage to find F<perlfunc>, 
     979for example, which is usually in F<pod/perlfunc> in most Perl dists.) 
     980 
     981The C<verbose> and C<inc> attributes influence the behavior of this 
     982search; notably, C<inc>, if true, adds @INC I<and also 
     983$Config::Config{'scriptdir'}> to the list of directories to search. 
     984 
     985It is common to simply say C<< $filename = Pod::Simple::Search-> new  
     986->find("perlvar") >> so that just the @INC (well, and scriptdir) 
     987directories are searched.  (This happens because the C<inc> 
     988attribute is true by default.) 
     989 
     990Calling Pod::Simple::Search->find(...) is short for 
     991Pod::Simple::Search->new->find(...).  That is, a throwaway object 
     992with default attribute values is used. 
     993 
     994 
     995=head2 C<< $self->contains_pod( $file ) >> 
     996 
     997Returns true if the supplied filename (not POD module) contains some Pod 
     998documentation. 
     999 
     1000 
     1001=head1 AUTHOR 
     1002 
     1003Sean M. Burke E<lt>sburke@cpan.orgE<gt> 
     1004borrowed code from 
     1005Marek Rouchal's Pod::Find, which in turn 
     1006heavily borrowed code from Nick Ing-Simmons' PodToHtml. 
     1007 
     1008Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided 
     1009C<find> and C<contains_pod> to Pod::Find. 
     1010 
     1011=head1 SEE ALSO 
     1012 
     1013L<Pod::Simple>, L<Pod::Perldoc> 
     1014 
     1015=cut 
     1016 
  • (a) /dev/null vs. (b) lib/Pod/Simple/HTMLBatch.pm

    a b  
     1 
     2require 5; 
     3package Pod::Simple::HTMLBatch; 
     4use strict; 
     5use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION 
     6 $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA 
     7); 
     8$VERSION = '3.02'; 
     9@ISA = ();  # Yup, we're NOT a subclass of Pod::Simple::HTML! 
     10 
     11# TODO: nocontents stylesheets. Strike some of the color variations? 
     12 
     13use Pod::Simple::HTML (); 
     14BEGIN {*esc = \&Pod::Simple::HTML::esc } 
     15use File::Spec (); 
     16use UNIVERSAL (); 
     17  # "Isn't the Universe an amazing place?  I wouldn't live anywhere else!" 
     18 
     19use Pod::Simple::Search; 
     20$SEARCH_CLASS ||= 'Pod::Simple::Search'; 
     21 
     22BEGIN { 
     23  if(defined &DEBUG) { } # no-op 
     24  elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } 
     25  else { *DEBUG = sub () {0}; } 
     26} 
     27 
     28$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; 
     29# flag to occasionally sleep for $SLEEPY - 1 seconds. 
     30 
     31$HTML_RENDER_CLASS ||= "Pod::Simple::HTML"; 
     32 
     33# 
     34# Methods beginning with "_" are particularly internal and possibly ugly. 
     35# 
     36 
     37Pod::Simple::_accessorize( __PACKAGE__, 
     38 'verbose', # how verbose to be during batch conversion 
     39 'html_render_class', # what class to use to render 
     40 'contents_file', # If set, should be the name of a file (in current directory) 
     41                  # to write the list of all modules to 
     42 'index', # will set $htmlpage->index(...) to this (true or false) 
     43 'progress', # progress object 
     44 'contents_page_start',  'contents_page_end', 
     45 
     46 'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad', 
     47 'no_contents_links', # set to true to suppress automatic adding of << links. 
     48 '_contents', 
     49); 
     50 
     51# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     52# Just so we can run from the command line more easily 
     53sub go { 
     54  @ARGV == 2 or die sprintf( 
     55    "Usage: perl -M%s -e %s:go indirs outdir\n  (or use \"\@INC\" for indirs)\n", 
     56    __PACKAGE__, __PACKAGE__,  
     57  ); 
     58   
     59  if(defined($ARGV[1]) and length($ARGV[1])) { 
     60    my $d = $ARGV[1]; 
     61    -e $d or die "I see no output directory named \"$d\"\nAborting"; 
     62    -d $d or die "But \"$d\" isn't a directory!\nAborting"; 
     63    -w $d or die "Directory \"$d\" isn't writeable!\nAborting"; 
     64  } 
     65   
     66  __PACKAGE__->batch_convert(@ARGV); 
     67} 
     68# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     69 
     70 
     71sub new { 
     72  my $new = bless {}, ref($_[0]) || $_[0]; 
     73  $new->html_render_class($HTML_RENDER_CLASS); 
     74  $new->verbose(1 + DEBUG); 
     75  $new->_contents([]); 
     76   
     77  $new->index(1); 
     78 
     79  $new->       _css_wad([]);         $new->css_flurry(1); 
     80  $new->_javascript_wad([]);  $new->javascript_flurry(1); 
     81   
     82  $new->contents_file( 
     83    'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION) 
     84  ); 
     85   
     86  $new->contents_page_start( join "\n", grep $_, 
     87    $Pod::Simple::HTML::Doctype_decl, 
     88    "<html><head>", 
     89    "<title>Perl Documentation</title>", 
     90    $Pod::Simple::HTML::Content_decl, 
     91    "</head>", 
     92    "\n<body class='contentspage'>\n<h1>Perl Documentation</h1>\n" 
     93  ); # override if you need a different title 
     94   
     95   
     96  $new->contents_page_end( sprintf( 
     97    "\n\n<p class='contentsfooty'>Generated by %s v%s under Perl v%s\n<br >At %s GMT, which is %s local time.</p>\n\n</body></html>\n", 
     98    esc( 
     99      ref($new), 
     100      eval {$new->VERSION} || $VERSION, 
     101      $], scalar(gmtime), scalar(localtime),  
     102  ))); 
     103 
     104  return $new; 
     105} 
     106 
     107# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     108 
     109sub muse { 
     110  my $self = shift; 
     111  if($self->verbose) { 
     112    print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n"; 
     113  } 
     114  return 1; 
     115} 
     116 
     117# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     118 
     119sub batch_convert { 
     120  my($self, $dirs, $outdir) = @_; 
     121  $self ||= __PACKAGE__; # tolerate being called as an optionless function 
     122  $self = $self->new unless ref $self; # tolerate being used as a class method 
     123 
     124  if(!defined($dirs)  or  $dirs eq ''  or  $dirs eq '@INC' ) { 
     125    $dirs = ''; 
     126  } elsif(ref $dirs) { 
     127    # OK, it's an explicit set of dirs to scan, specified as an arrayref. 
     128  } else { 
     129    # OK, it's an explicit set of dirs to scan, specified as a 
     130    #  string like "/thing:/also:/whatever/perl" (":"-delim, as usual) 
     131    #  or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!) 
     132    require Config; 
     133    my $ps = quotemeta( $Config::Config{'path_sep'} || ":" ); 
     134    $dirs = [ grep length($_), split qr/$ps/, $dirs ]; 
     135  } 
     136 
     137  $outdir = $self->filespecsys->curdir 
     138   unless defined $outdir and length $outdir; 
     139 
     140  $self->_batch_convert_main($dirs, $outdir); 
     141} 
     142 
     143# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     144 
     145sub _batch_convert_main { 
     146  my($self, $dirs, $outdir) = @_; 
     147  # $dirs is either false, or an arrayref.     
     148  # $outdir is a pathspec. 
     149   
     150  $self->{'_batch_start_time'} ||= time(); 
     151 
     152  $self->muse( "= ", scalar(localtime) ); 
     153  $self->muse( "Starting batch conversion to \"$outdir\"" ); 
     154 
     155  my $progress = $self->progress; 
     156  if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) { 
     157    require Pod::Simple::Progress; 
     158    $progress = Pod::Simple::Progress->new( 
     159        ($self->verbose  < 2) ? () # Default omission-delay 
     160      : ($self->verbose == 2) ? 1  # Reduce the omission-delay 
     161                              : 0  # Eliminate the omission-delay 
     162    ); 
     163    $self->progress($progress); 
     164  } 
     165   
     166  if($dirs) { 
     167    $self->muse(scalar(@$dirs), " dirs to scan: @$dirs"); 
     168  } else { 
     169    $self->muse("Scanning \@INC.  This could take a minute or two."); 
     170  } 
     171  my $mod2path = $self->find_all_pods($dirs ? $dirs : ()); 
     172  $self->muse("Done scanning."); 
     173 
     174  my $total = keys %$mod2path; 
     175  unless($total) { 
     176    $self->muse("No pod found.  Aborting batch conversion.\n"); 
     177    return $self; 
     178  } 
     179 
     180  $progress and $progress->goal($total); 
     181  $self->muse("Now converting pod files to HTML.", 
     182    ($total > 25) ? "  This will take a while more." : () 
     183  ); 
     184 
     185  $self->_spray_css(        $outdir ); 
     186  $self->_spray_javascript( $outdir ); 
     187 
     188  $self->_do_all_batch_conversions($mod2path, $outdir); 
     189 
     190  $progress and $progress->done(sprintf ( 
     191    "Done converting %d files.",  $self->{"__batch_conv_page_count"} 
     192  )); 
     193  return $self->_batch_convert_finish($outdir); 
     194  return $self; 
     195} 
     196 
     197 
     198sub _do_all_batch_conversions { 
     199  my($self, $mod2path, $outdir) = @_; 
     200  $self->{"__batch_conv_page_count"} = 0; 
     201 
     202  foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) { 
     203    $self->_do_one_batch_conversion($module, $mod2path, $outdir); 
     204    sleep($SLEEPY - 1) if $SLEEPY; 
     205  } 
     206 
     207  return; 
     208} 
     209 
     210sub _batch_convert_finish { 
     211  my($self, $outdir) = @_; 
     212  $self->write_contents_file($outdir); 
     213  $self->muse("Done with batch conversion.  $$self{'__batch_conv_page_count'} files done."); 
     214  $self->muse( "= ", scalar(localtime) ); 
     215  $self->progress and $self->progress->done("All done!"); 
     216  return; 
     217} 
     218 
     219# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     220 
     221sub _do_one_batch_conversion { 
     222  my($self, $module, $mod2path, $outdir, $outfile) = @_; 
     223 
     224  my $retval; 
     225  my $total    = scalar keys %$mod2path; 
     226  my $infile   = $mod2path->{$module}; 
     227  my @namelets = grep m/\S/, split "::", $module; 
     228        # this can stick around in the contents LoL 
     229  my $depth    = scalar @namelets; 
     230  die "Contentless thingie?! $module $infile" unless @namelets; #sanity 
     231     
     232  $outfile  ||= do { 
     233    my @n = @namelets; 
     234    $n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION; 
     235    $self->filespecsys->catfile( $outdir, @n ); 
     236  }; 
     237 
     238  my $progress = $self->progress; 
     239 
     240  my $page = $self->html_render_class->new; 
     241  if(DEBUG > 5) { 
     242    $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ", 
     243      ref($page), " render ($depth) $module => $outfile"); 
     244  } elsif(DEBUG > 2) { 
     245    $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile") 
     246  } 
     247 
     248  # Give each class a chance to init the converter: 
     249   
     250  $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth) 
     251   if $page->can('batch_mode_page_object_init'); 
     252  $self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth) 
     253   if $self->can('batch_mode_page_object_init'); 
     254     
     255  # Now get busy... 
     256  $self->makepath($outdir => \@namelets); 
     257 
     258  $progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module"); 
     259 
     260  if( $retval = $page->parse_from_file($infile, $outfile) ) { 
     261    ++ $self->{"__batch_conv_page_count"} ; 
     262    $self->note_for_contents_file( \@namelets, $infile, $outfile ); 
     263  } else { 
     264    $self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false."); 
     265  } 
     266 
     267  $page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth) 
     268   if $page->can('batch_mode_page_object_kill'); 
     269  # The following isn't a typo.  Note that it switches $self and $page. 
     270  $self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth) 
     271   if $self->can('batch_mode_page_object_kill'); 
     272     
     273  DEBUG > 4 and printf "%s %sb < $infile %s %sb\n", 
     274     $outfile, -s $outfile, $infile, -s $infile 
     275  ; 
     276 
     277  undef($page); 
     278  return $retval; 
     279} 
     280 
     281# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     282sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' } 
     283 
     284# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     285 
     286sub note_for_contents_file { 
     287  my($self, $namelets, $infile, $outfile) = @_; 
     288 
     289  # I think the infile and outfile parts are never used. -- SMB 
     290  # But it's handy to have them around for debugging. 
     291 
     292  if( $self->contents_file ) { 
     293    my $c = $self->_contents(); 
     294    push @$c, 
     295     [ join("::", @$namelets), $infile, $outfile, $namelets ] 
     296     #            0               1         2         3 
     297    ; 
     298    DEBUG > 3 and print "Noting @$c[-1]\n"; 
     299  } 
     300  return; 
     301} 
     302 
     303#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- 
     304 
     305sub write_contents_file { 
     306  my($self, $outdir) = @_; 
     307  my $outfile  = $self->_contents_filespec($outdir) || return; 
     308 
     309  $self->muse("Preparing list of modules for ToC"); 
     310 
     311  my($toplevel,           # maps  toplevelbit => [all submodules] 
     312     $toplevel_form_freq, # ends up being  'foo' => 'Foo' 
     313    ) = $self->_prep_contents_breakdown; 
     314 
     315  my $Contents = eval { $self->_wopen($outfile) }; 
     316  if( $Contents ) { 
     317    $self->muse( "Writing contents file $outfile" ); 
     318  } else { 
     319    warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all"; 
     320    return; 
     321  } 
     322 
     323  $self->_write_contents_start(  $Contents, $outfile, ); 
     324  $self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq ); 
     325  $self->_write_contents_end(    $Contents, $outfile, ); 
     326  return $outfile; 
     327} 
     328 
     329# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     330 
     331sub _write_contents_start { 
     332  my($self, $Contents, $outfile) = @_; 
     333  my $starter = $self->contents_page_start || ''; 
     334   
     335  { 
     336    my $css_wad = $self->_css_wad_to_markup(1); 
     337    if( $css_wad ) { 
     338      $starter =~ s{(</head>)}{\n$css_wad\n$1}i;  # otherwise nevermind 
     339    } 
     340     
     341    my $javascript_wad = $self->_javascript_wad_to_markup(1); 
     342    if( $javascript_wad ) { 
     343      $starter =~ s{(</head>)}{\n$javascript_wad\n$1}i;   # otherwise nevermind 
     344    } 
     345  } 
     346 
     347  unless(print $Contents $starter, "<dl class='superindex'>\n" ) { 
     348    warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; 
     349    close($Contents); 
     350    return 0; 
     351  } 
     352  return 1; 
     353} 
     354 
     355# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     356 
     357sub _write_contents_middle { 
     358  my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_; 
     359 
     360  foreach my $t (sort keys %$toplevel2submodules) { 
     361    my @downlines = sort {$a->[-1] cmp $b->[-1]} 
     362                          @{ $toplevel2submodules->{$t} }; 
     363     
     364    printf $Contents qq[<dt><a name="%s">%s</a></dt>\n<dd>\n], 
     365      esc( $t, $toplevel_form_freq->{$t} ) 
     366    ; 
     367     
     368    my($path, $name); 
     369    foreach my $e (@downlines) { 
     370      $name = $e->[0]; 
     371      $path = join( "/", '.', esc( @{$e->[3]} ) ) 
     372        . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION); 
     373      print $Contents qq{  <a href="$path">}, esc($name), "</a>&nbsp;&nbsp;\n"; 
     374    } 
     375    print $Contents "</dd>\n\n"; 
     376  } 
     377  return 1; 
     378} 
     379 
     380# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     381 
     382sub _write_contents_end { 
     383  my($self, $Contents, $outfile) = @_; 
     384  unless( 
     385    print $Contents "</dl>\n", 
     386      $self->contents_page_end || '', 
     387  ) { 
     388    warn "Couldn't write to $outfile: $!"; 
     389  } 
     390  close($Contents) or warn "Couldn't close $outfile: $!"; 
     391  return 1; 
     392} 
     393 
     394# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     395 
     396sub _prep_contents_breakdown { 
     397  my($self) = @_; 
     398  my $contents = $self->_contents; 
     399  my %toplevel; # maps  lctoplevelbit => [all submodules] 
     400  my %toplevel_form_freq; # ends up being  'foo' => 'Foo' 
     401                               # (mapping anycase forms to most freq form) 
     402   
     403  foreach my $entry (@$contents) { 
     404    my $toplevel =  
     405      $entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs' 
     406          # group all the perlwhatever docs together 
     407      : $entry->[3][0] # normal case 
     408    ; 
     409    ++$toplevel_form_freq{ lc $toplevel }{ $toplevel }; 
     410    push @{ $toplevel{ lc $toplevel } }, $entry; 
     411    push @$entry, lc($entry->[0]); # add a sort-order key to the end 
     412  } 
     413 
     414  foreach my $toplevel (sort keys %toplevel) { 
     415    my $fgroup = $toplevel_form_freq{$toplevel}; 
     416    $toplevel_form_freq{$toplevel} = 
     417    ( 
     418      sort { $fgroup->{$b} <=> $fgroup->{$a}  or  $a cmp $b } 
     419        keys %$fgroup 
     420      # This hash is extremely unlikely to have more than 4 members, so this 
     421      # sort isn't so very wasteful 
     422    )[0]; 
     423  } 
     424 
     425  return(\%toplevel, \%toplevel_form_freq) if wantarray; 
     426  return \%toplevel; 
     427} 
     428 
     429# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     430 
     431sub _contents_filespec { 
     432  my($self, $outdir) = @_; 
     433  my $outfile = $self->contents_file; 
     434  return unless $outfile; 
     435  return $self->filespecsys->catfile( $outdir, $outfile ); 
     436} 
     437 
     438#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- 
     439 
     440sub makepath { 
     441  my($self, $outdir, $namelets) = @_; 
     442  return unless @$namelets > 1; 
     443  for my $i (0 .. ($#$namelets - 1)) { 
     444    my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] ); 
     445    if(-e $dir) { 
     446      die "$dir exists but not as a directory!?" unless -d $dir; 
     447      next; 
     448    } 
     449    DEBUG > 3 and print "  Making $dir\n"; 
     450    mkdir $dir, 0777 
     451     or die "Can't mkdir $dir: $!\nAborting" 
     452    ; 
     453  } 
     454  return; 
     455} 
     456 
     457#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- 
     458 
     459sub batch_mode_page_object_init { 
     460  my $self = shift; 
     461  my($page, $module, $infile, $outfile, $depth) = @_; 
     462   
     463  # TODO: any further options to percolate onto this new object here? 
     464 
     465  $page->default_title($module); 
     466  $page->index( $self->index ); 
     467 
     468  $page->html_css(        $self->       _css_wad_to_markup($depth) ); 
     469  $page->html_javascript( $self->_javascript_wad_to_markup($depth) ); 
     470 
     471  $self->add_header_backlink($page, $module, $infile, $outfile, $depth); 
     472  $self->add_footer_backlink($page, $module, $infile, $outfile, $depth); 
     473 
     474 
     475  return $self; 
     476} 
     477 
     478# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     479 
     480sub add_header_backlink { 
     481  my $self = shift; 
     482  return if $self->no_contents_links; 
     483  my($page, $module, $infile, $outfile, $depth) = @_; 
     484  $page->html_header_after_title( join '', 
     485    $page->html_header_after_title || '', 
     486 
     487    qq[<p class="backlinktop"><b><a name="___top" href="], 
     488    $self->url_up_to_contents($depth), 
     489    qq[" accesskey="1" title="All Documents">&lt;&lt;</a></b></p>\n], 
     490  ) 
     491   if $self->contents_file 
     492  ; 
     493  return; 
     494} 
     495 
     496sub add_footer_backlink { 
     497  my $self = shift; 
     498  return if $self->no_contents_links; 
     499  my($page, $module, $infile, $outfile, $depth) = @_; 
     500  $page->html_footer( join '', 
     501    qq[<p class="backlinkbottom"><b><a name="___bottom" href="], 
     502    $self->url_up_to_contents($depth), 
     503    qq[" title="All Documents">&lt;&lt;</a></b></p>\n], 
     504     
     505    $page->html_footer || '', 
     506  ) 
     507   if $self->contents_file 
     508  ; 
     509  return; 
     510} 
     511 
     512sub url_up_to_contents { 
     513  my($self, $depth) = @_; 
     514  --$depth; 
     515  return join '/', ('..') x $depth, esc($self->contents_file); 
     516} 
     517 
     518#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- 
     519 
     520sub find_all_pods { 
     521  my($self, $dirs) = @_; 
     522  # You can override find_all_pods in a subclass if you want to 
     523  #  do extra filtering or whatnot.  But for the moment, we just 
     524  #  pass to modnames2paths: 
     525  return $self->modnames2paths($dirs); 
     526} 
     527 
     528#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- 
     529 
     530sub modnames2paths { # return a hashref mapping modulenames => paths 
     531  my($self, $dirs) = @_; 
     532 
     533  my $m2p; 
     534  { 
     535    my $search = $SEARCH_CLASS->new; 
     536    DEBUG and print "Searching via $search\n"; 
     537    $search->verbose(1) if DEBUG > 10; 
     538    $search->progress( $self->progress->copy->goal(0) ) if $self->progress; 
     539    $search->shadows(0);  # don't bother noting shadowed files 
     540    $search->inc(     $dirs ? 0      :  1 ); 
     541    $search->survey(  $dirs ? @$dirs : () ); 
     542    $m2p = $search->name2path; 
     543    die "What, no name2path?!" unless $m2p; 
     544  } 
     545 
     546  $self->muse("That's odd... no modules found!") unless keys %$m2p; 
     547  if( DEBUG > 4 ) { 
     548    print "Modules found (name => path):\n"; 
     549    foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) { 
     550      print "  $m  $$m2p{$m}\n"; 
     551    } 
     552    print "(total ",     scalar(keys %$m2p), ")\n\n"; 
     553  } elsif( DEBUG ) { 
     554    print      "Found ", scalar(keys %$m2p), " modules.\n"; 
     555  } 
     556  $self->muse( "Found ", scalar(keys %$m2p), " modules." ); 
     557   
     558  # return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref 
     559  return $m2p; 
     560} 
     561 
     562#=========================================================================== 
     563 
     564sub _wopen { 
     565  # this is abstracted out so that the daemon class can override it 
     566  my($self, $outpath) = @_; 
     567  require Symbol; 
     568  my $out_fh = Symbol::gensym(); 
     569  DEBUG > 5 and print "Write-opening to $outpath\n"; 
     570  return $out_fh if open($out_fh, ">", "$outpath"); 
     571  require Carp;   
     572  Carp::croak("Can't write-open $outpath: $!"); 
     573} 
     574 
     575#========================================================================== 
     576 
     577sub add_css { 
     578  my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_; 
     579  return unless $url; 
     580  unless($name) { 
     581    # cook up a reasonable name based on the URL 
     582    $name = $url; 
     583    if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) { 
     584      $name = $1; 
     585      $name =~ s/\.css//i; 
     586    } 
     587  } 
     588  $media        ||= 'all'; 
     589  $content_type ||= 'text/css'; 
     590   
     591  my $bunch = [$url, $name, $content_type, $media, $_code]; 
     592  if($is_default) { unshift @{ $self->_css_wad }, $bunch } 
     593  else            { push    @{ $self->_css_wad }, $bunch } 
     594  return; 
     595} 
     596 
     597# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     598 
     599sub _spray_css { 
     600  my($self, $outdir) = @_; 
     601 
     602  return unless $self->css_flurry(); 
     603  $self->_gen_css_wad(); 
     604 
     605  my $lol = $self->_css_wad; 
     606  foreach my $chunk (@$lol) { 
     607    my $url = $chunk->[0]; 
     608    my $outfile; 
     609    if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) { 
     610      $outfile = $self->filespecsys->catfile( $outdir, "$1" ); 
     611      DEBUG > 5 and print "Noting $$chunk[0] as a file I'll create.\n"; 
     612    } else { 
     613      DEBUG > 5 and print "OK, noting $$chunk[0] as an external CSS.\n"; 
     614      # Requires no further attention. 
     615      next; 
     616    } 
     617     
     618    #$self->muse( "Writing autogenerated CSS file $outfile" ); 
     619    my $Cssout = $self->_wopen($outfile); 
     620    print $Cssout ${$chunk->[-1]} 
     621     or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; 
     622    close($Cssout); 
     623    DEBUG > 5 and print "Wrote $outfile\n"; 
     624  } 
     625 
     626  return; 
     627} 
     628 
     629# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     630 
     631sub _css_wad_to_markup { 
     632  my($self, $depth) = @_; 
     633   
     634  my @css  = @{ $self->_css_wad || return '' }; 
     635  return '' unless @css; 
     636   
     637  my $rel = 'stylesheet'; 
     638  my $out = ''; 
     639 
     640  --$depth; 
     641  my $uplink = $depth ? ('../' x $depth) : ''; 
     642 
     643  foreach my $chunk (@css) { 
     644    next unless $chunk and @$chunk; 
     645 
     646    my( $url1, $url2, $title, $type, $media) = ( 
     647      $self->_maybe_uplink( $chunk->[0], $uplink ), 
     648      esc(grep !ref($_), @$chunk) 
     649    ); 
     650 
     651    $out .= qq{<link rel="$rel" title="$title" type="$type" href="$url1$url2" media="$media" >\n}; 
     652 
     653    $rel = 'alternate stylesheet'; # alternates = all non-first iterations 
     654  } 
     655  return $out; 
     656} 
     657 
     658# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     659sub _maybe_uplink { 
     660  # if the given URL looks relative, return the given uplink string -- 
     661  # otherwise return emptystring 
     662  my($self, $url, $uplink) = @_; 
     663  ($url =~ m{^\./} or $url !~ m{[/\:]} ) 
     664    ? $uplink 
     665    : '' 
     666    # qualify it, if/as needed 
     667} 
     668 
     669# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     670sub _gen_css_wad { 
     671  my $self = $_[0]; 
     672  my $css_template = $self->_css_template; 
     673  foreach my $variation ( 
     674 
     675   # Commented out for sake of concision: 
     676   # 
     677   #  011n=black_with_red_on_white 
     678   #  001n=black_with_yellow_on_white 
     679   #  101n=black_with_green_on_white 
     680   #  110=white_with_yellow_on_black 
     681   #  010=white_with_green_on_black 
     682   #  011=white_with_blue_on_black 
     683   #  100=white_with_red_on_black 
     684   
     685   qw[ 
     686    110n=black_with_blue_on_white 
     687    010n=black_with_magenta_on_white 
     688    100n=black_with_cyan_on_white 
     689 
     690    101=white_with_purple_on_black 
     691    001=white_with_navy_blue_on_black 
     692 
     693    010a=grey_with_green_on_black 
     694    010b=white_with_green_on_grey 
     695    101an=black_with_green_on_grey 
     696    101bn=grey_with_green_on_white 
     697  ]) { 
     698 
     699    my $outname = $variation; 
     700    my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3) 
     701      if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s; 
     702    @swap = () if '010' eq join '', @swap; # 010 is a swop-no-op! 
     703   
     704    my $this_css = 
     705      "/* This file is autogenerated.  Do not edit.  $variation */\n\n" 
     706      . $css_template; 
     707 
     708    # Only look at three-digitty colors, for now at least. 
     709    if( $flipmode =~ m/n/ ) { 
     710      $this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg; 
     711      $this_css =~ s/\bthin\b/medium/g; 
     712    } 
     713    $this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b> 
     714                  < join '', '#', ($1,$2,$3)[@swap] >eg   if @swap; 
     715 
     716    if(   $flipmode =~ m/a/) 
     717       { $this_css =~ s/#fff\b/#999/gi } # black -> dark grey 
     718    elsif($flipmode =~ m/b/) 
     719       { $this_css =~ s/#000\b/#666/gi } # white -> light grey 
     720 
     721    my $name = $outname;     
     722    $name =~ tr/-_/  /; 
     723    $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css); 
     724  } 
     725 
     726  # Now a few indexless variations: 
     727  foreach my $variation (qw[ 
     728    black_with_blue_on_white  white_with_purple_on_black 
     729    white_with_green_on_grey  grey_with_green_on_white 
     730  ]) { 
     731    my $outname = "indexless_$variation"; 
     732    my $this_css = join "\n", 
     733      "/* This file is autogenerated.  Do not edit.  $outname */\n", 
     734      "\@import url(\"./_$variation.css\");", 
     735      ".indexgroup { display: none; }", 
     736      "\n", 
     737    ; 
     738    my $name = $outname;     
     739    $name =~ tr/-_/  /; 
     740    $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css); 
     741  } 
     742 
     743  return; 
     744} 
     745 
     746sub _color_negate { 
     747  my $x = lc $_[0]; 
     748  $x =~ tr[0123456789abcdef] 
     749          [fedcba9876543210]; 
     750  return $x; 
     751} 
     752 
     753#=========================================================================== 
     754 
     755sub add_javascript { 
     756  my($self, $url, $content_type, $_code) = @_; 
     757  return unless $url; 
     758  push  @{ $self->_javascript_wad }, [ 
     759    $url, $content_type || 'text/javascript', $_code 
     760  ]; 
     761  return; 
     762} 
     763 
     764sub _spray_javascript { 
     765  my($self, $outdir) = @_; 
     766  return unless $self->javascript_flurry(); 
     767  $self->_gen_javascript_wad(); 
     768 
     769  my $lol = $self->_javascript_wad; 
     770  foreach my $script (@$lol) { 
     771    my $url = $script->[0]; 
     772    my $outfile; 
     773     
     774    if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) { 
     775      $outfile = $self->filespecsys->catfile( $outdir, "$1" ); 
     776      DEBUG > 5 and print "Noting $$script[0] as a file I'll create.\n"; 
     777    } else { 
     778      DEBUG > 5 and print "OK, noting $$script[0] as an external JavaScript.\n"; 
     779      next; 
     780    } 
     781     
     782    #$self->muse( "Writing JavaScript file $outfile" ); 
     783    my $Jsout = $self->_wopen($outfile); 
     784 
     785    print $Jsout ${$script->[-1]} 
     786     or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; 
     787    close($Jsout); 
     788    DEBUG > 5 and print "Wrote $outfile\n"; 
     789  } 
     790 
     791  return; 
     792} 
     793 
     794sub _gen_javascript_wad { 
     795  my $self = $_[0]; 
     796  my $js_code = $self->_javascript || return; 
     797  $self->add_javascript( "_podly.js", 0, \$js_code); 
     798  return; 
     799} 
     800 
     801sub _javascript_wad_to_markup { 
     802  my($self, $depth) = @_; 
     803   
     804  my @scripts  = @{ $self->_javascript_wad || return '' }; 
     805  return '' unless @scripts; 
     806   
     807  my $out = ''; 
     808 
     809  --$depth; 
     810  my $uplink = $depth ? ('../' x $depth) : ''; 
     811 
     812  foreach my $s (@scripts) { 
     813    next unless $s and @$s; 
     814 
     815    my( $url1, $url2, $type, $media) = ( 
     816      $self->_maybe_uplink( $s->[0], $uplink ), 
     817      esc(grep !ref($_), @$s) 
     818    ); 
     819 
     820    $out .= qq{<script type="$type" src="$url1$url2"></script>\n}; 
     821  } 
     822  return $out; 
     823} 
     824 
     825#=========================================================================== 
     826 
     827sub _css_template { return $CSS } 
     828sub _javascript   { return $JAVASCRIPT } 
     829 
     830$CSS = <<'EOCSS'; 
     831/* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */ 
     832 
     833@media all { .hide { display: none; } } 
     834 
     835@media print { 
     836  .noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none } 
     837 
     838  * { 
     839    border-color: black !important; 
     840    color: black !important; 
     841    background-color: transparent !important; 
     842    background-image: none !important; 
     843  } 
     844 
     845  dl.superindex > dd  { 
     846    word-spacing: .6em; 
     847  } 
     848} 
     849 
     850@media aural, braille, embossed { 
     851  div.indexgroup  { display: none; }  /* Too noisy, don't you think? */ 
     852  dl.superindex > dt:before { content: "Group ";  } 
     853  dl.superindex > dt:after  { content: " contains:"; } 
     854  .backlinktop    a:before  { content: "Back to contents"; } 
     855  .backlinkbottom a:before  { content: "Back to contents"; } 
     856} 
     857 
     858@media aural { 
     859  dl.superindex > dt  { pause-before: 600ms; } 
     860} 
     861 
     862@media screen, tty, tv, projection { 
     863  .noscreen { display: none; } 
     864 
     865  a:link    { color: #7070ff; text-decoration: underline; } 
     866  a:visited { color: #e030ff; text-decoration: underline; } 
     867  a:active  { color: #800000; text-decoration: underline; } 
     868  body.contentspage a            { text-decoration: none; } 
     869  a.u { color: #fff !important; text-decoration: none; } 
     870 
     871  body.pod { 
     872    margin: 0 5px; 
     873    color:            #fff; 
     874    background-color: #000; 
     875  } 
     876 
     877  body.pod h1, body.pod h2, body.pod h3, body.pod h4  { 
     878    font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; 
     879    font-weight: normal; 
     880    margin-top: 1.2em; 
     881    margin-bottom: .1em; 
     882    border-top: thin solid transparent; 
     883    /* margin-left: -5px;  border-left: 2px #7070ff solid;  padding-left: 3px; */ 
     884  } 
     885   
     886  body.pod h1  { border-top-color: #0a0; } 
     887  body.pod h2  { border-top-color: #080; } 
     888  body.pod h3  { border-top-color: #040; } 
     889  body.pod h4  { border-top-color: #010; } 
     890 
     891  p.backlinktop + h1 { border-top: none; margin-top: 0em;  } 
     892  p.backlinktop + h2 { border-top: none; margin-top: 0em;  } 
     893  p.backlinktop + h3 { border-top: none; margin-top: 0em;  } 
     894  p.backlinktop + h4 { border-top: none; margin-top: 0em;  } 
     895 
     896  body.pod dt { 
     897    font-size: 105%; /* just a wee bit more than normal */ 
     898  } 
     899 
     900  .indexgroup { font-size: 80%; } 
     901 
     902  .backlinktop,   .backlinkbottom    { 
     903    margin-left:  -5px; 
     904    margin-right: -5px; 
     905    background-color:         #040; 
     906    border-top:    thin solid #050; 
     907    border-bottom: thin solid #050; 
     908  } 
     909   
     910  .backlinktop a, .backlinkbottom a  { 
     911    text-decoration: none; 
     912    color: #080; 
     913    background-color:  #000; 
     914    border: thin solid #0d0; 
     915  } 
     916  .backlinkbottom { margin-bottom: 0; padding-bottom: 0; } 
     917  .backlinktop    { margin-top:    0; padding-top:    0; } 
     918 
     919  body.contentspage { 
     920    color:            #fff; 
     921    background-color: #000; 
     922  } 
     923   
     924  body.contentspage h1  { 
     925    color:            #0d0; 
     926    margin-left: 1em; 
     927    margin-right: 1em; 
     928    text-indent: -.9em; 
     929    font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; 
     930    font-weight: normal; 
     931    border-top:    thin solid #fff; 
     932    border-bottom: thin solid #fff; 
     933    text-align: center; 
     934  } 
     935 
     936  dl.superindex > dt  { 
     937    font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; 
     938    font-weight: normal; 
     939    font-size: 90%; 
     940    margin-top: .45em; 
     941    /* margin-bottom: -.15em; */ 
     942  } 
     943  dl.superindex > dd  { 
     944    word-spacing: .6em;    /* most important rule here! */ 
     945  } 
     946  dl.superindex > a:link  { 
     947    text-decoration: none; 
     948    color: #fff; 
     949  } 
     950 
     951  .contentsfooty { 
     952    border-top: thin solid #999; 
     953    font-size: 90%; 
     954  } 
     955   
     956} 
     957 
     958/* The End */ 
     959 
     960EOCSS 
     961 
     962#========================================================================== 
     963 
     964$JAVASCRIPT = <<'EOJAVASCRIPT'; 
     965 
     966// From http://www.alistapart.com/articles/alternate/ 
     967 
     968function setActiveStyleSheet(title) { 
     969  var i, a, main; 
     970  for(i=0  ;  (a = document.getElementsByTagName("link")[i])  ;  i++) { 
     971    if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) { 
     972      a.disabled = true; 
     973      if(a.getAttribute("title") == title) a.disabled = false; 
     974    } 
     975  } 
     976} 
     977 
     978function getActiveStyleSheet() { 
     979  var i, a; 
     980  for(i=0  ;  (a = document.getElementsByTagName("link")[i])  ;  i++) { 
     981    if(   a.getAttribute("rel").indexOf("style") != -1 
     982       && a.getAttribute("title") 
     983       && !a.disabled 
     984       ) return a.getAttribute("title"); 
     985  } 
     986  return null; 
     987} 
     988 
     989function getPreferredStyleSheet() { 
     990  var i, a; 
     991  for(i=0  ;  (a = document.getElementsByTagName("link")[i])  ;  i++) { 
     992    if(   a.getAttribute("rel").indexOf("style") != -1 
     993       && a.getAttribute("rel").indexOf("alt") == -1 
     994       && a.getAttribute("title") 
     995       ) return a.getAttribute("title"); 
     996  } 
     997  return null; 
     998} 
     999 
     1000function createCookie(name,value,days) { 
     1001  if (days) { 
     1002    var date = new Date(); 
     1003    date.setTime(date.getTime()+(days*24*60*60*1000)); 
     1004    var expires = "; expires="+date.toGMTString(); 
     1005  } 
     1006  else expires = ""; 
     1007  document.cookie = name+"="+value+expires+"; path=/"; 
     1008} 
     1009 
     1010function readCookie(name) { 
     1011  var nameEQ = name + "="; 
     1012  var ca = document.cookie.split(';'); 
     1013  for(var i=0  ;  i < ca.length  ;  i++) { 
     1014    var c = ca[i]; 
     1015    while (c.charAt(0)==' ') c = c.substring(1,c.length); 
     1016    if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length); 
     1017  } 
     1018  return null; 
     1019} 
     1020 
     1021window.onload = function(e) { 
     1022  var cookie = readCookie("style"); 
     1023  var title = cookie ? cookie : getPreferredStyleSheet(); 
     1024  setActiveStyleSheet(title); 
     1025} 
     1026 
     1027window.onunload = function(e) { 
     1028  var title = getActiveStyleSheet(); 
     1029  createCookie("style", title, 365); 
     1030} 
     1031 
     1032var cookie = readCookie("style"); 
     1033var title = cookie ? cookie : getPreferredStyleSheet(); 
     1034setActiveStyleSheet(title); 
     1035 
     1036// The End 
     1037 
     1038EOJAVASCRIPT 
     1039 
     1040# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
     10411; 
     1042__END__ 
     1043 
     1044 
     1045=head1 NAME 
     1046 
     1047Pod::Simple::HTMLBatch - convert several Pod files to several HTML files 
     1048 
     1049=head1 SYNOPSIS 
     1050 
     1051  perl -MPod::Simple::HTMLBatch -e 'Pod::Simple::HTMLBatch::go' in out 
     1052 
     1053 
     1054=head1 DESCRIPTION 
     1055 
     1056This module is used for running batch-conversions of a lot of HTML 
     1057documents  
     1058 
     1059This class is NOT a subclass of Pod::Simple::HTML 
     1060(nor of bad old Pod::Html) -- although it uses 
     1061Pod::Simple::HTML for doing the conversion of each document. 
     1062 
     1063The normal use of this class is like so: 
     1064 
     1065  use Pod::Simple::HTMLBatch; 
     1066  my $batchconv = Pod::Simple::HTMLBatch->new; 
     1067  $batchconv->some_option( some_value ); 
     1068  $batchconv->some_other_option( some_other_value ); 
     1069  $batchconv->batch_convert( \@search_dirs, $output_dir ); 
     1070 
     1071=head2 FROM THE COMMAND LINE 
     1072 
     1073Note that this class also provides 
     1074(but does not export) the function Pod::Simple::HTMLBatch::go. 
     1075This is basically just a shortcut for C<< 
     1076Pod::Simple::HTMLBatch->batch_convert(@ARGV) >>. 
     1077It's meant to be handy for calling from the command line. 
     1078 
     1079However, the shortcut requires that you specify exactly two command-line 
     1080arguments, C<indirs> and C<outdir>. 
     1081 
     1082Example: 
     1083 
     1084  % mkdir out_html 
     1085  % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html 
     1086      (to convert the pod from Perl's @INC 
     1087       files under the directory ../htmlversion) 
     1088 
     1089(Note that the command line there contains a literal atsign-I-N-C.  This 
     1090is handled as a special case by batch_convert, in order to save you having 
     1091to enter the odd-looking "" as the first command-line parameter when you 
     1092mean "just use whatever's in @INC".) 
     1093 
     1094Example: 
     1095 
     1096  % mkdir ../seekrut 
     1097  % chmod og-rx ../seekrut 
     1098  % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../htmlversion 
     1099      (to convert the pod under the current dir into HTML 
     1100       files under the directory ../htmlversion) 
     1101 
     1102Example: 
     1103 
     1104  % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go happydocs . 
     1105      (to convert all pod from happydocs into the current directory) 
     1106 
     1107 
     1108 
     1109=head1 MAIN METHODS 
     1110 
     1111=over 
     1112 
     1113=item $batchconv = Pod::Simple::HTMLBatch->new; 
     1114 
     1115This TODO 
     1116 
     1117 
     1118=item $batchconv->batch_convert( I<indirs>, I<outdir> ); 
     1119 
     1120this TODO 
     1121 
     1122=item $batchconv->batch_convert( undef    , ...); 
     1123 
     1124=item $batchconv->batch_convert( q{@INC}, ...); 
     1125 
     1126These two values for I<indirs> specify that the normal Perl @INC 
     1127 
     1128=item $batchconv->batch_convert( \@dirs , ...); 
     1129 
     1130This specifies that the input directories are the items in 
     1131the arrayref C<\@dirs>. 
     1132 
     1133=item $batchconv->batch_convert( "somedir" , ...); 
     1134 
     1135This specifies that the director "somedir" is the input. 
     1136(This can be an absolute or relative path, it doesn't matter.) 
     1137 
     1138A common value you might want would be just "." for the current 
     1139directory: 
     1140 
     1141     $batchconv->batch_convert( "." , ...); 
     1142 
     1143 
     1144=item $batchconv->batch_convert( 'somedir:someother:also' , ...); 
     1145 
     1146This specifies that you want the dirs "somedir", "somother", and "also" 
     1147scanned, just as if you'd passed the arrayref 
     1148C<[qw( somedir someother also)]>.  Note that a ":"-separator is normal 
     1149under Unix, but Under MSWin, you'll need C<'somedir;someother;also'> 
     1150instead, since the pathsep on MSWin is ";" instead of ":".  (And 
     1151I<that> is because ":" often comes up in paths, like 
     1152C<"c:/perl/lib">.) 
     1153 
     1154(Exactly what separator character should be used, is gotten from 
     1155C<$Config::Config{'path_sep'}>, via the L<Config> module.) 
     1156 
     1157=item $batchconv->batch_convert( ... , undef ); 
     1158 
     1159This specifies that you want the HTML output to go into the current 
     1160directory. 
     1161 
     1162(Note that a missing or undefined value means a different thing in 
     1163the first slot than in the second.  That's so that C<batch_convert()> 
     1164with no arguments (or undef arguments) means "go from @INC, into 
     1165the current directory.) 
     1166 
     1167=item $batchconv->batch_convert( ... , 'somedir' ); 
     1168 
     1169This specifies that you want the HTML output to go into the 
     1170directory 'somedir'. 
     1171(This can be an absolute or relative path, it doesn't matter.) 
     1172 
     1173=back 
     1174 
     1175 
     1176Note that you can also call C<batch_convert> as a class method, 
     1177like so: 
     1178 
     1179  Pod::Simple::HTMLBatch->batch_convert( ... ); 
     1180 
     1181That is just short for this: 
     1182 
     1183  Pod::Simple::HTMLBatch-> new-> batch_convert(...); 
     1184 
     1185That is, it runs a conversion with default options, for 
     1186whatever inputdirs and output dir you specify. 
     1187 
     1188 
     1189=head2 ACCESSOR METHODS 
     1190 
     1191The following are all accessor methods -- that is, they don't do anything 
     1192on their own, but just alter the contents of the conversion object, 
     1193which comprises the options for this particular batch conversion. 
     1194 
     1195We show the "put" form of the accessors below (i.e., the syntax you use 
     1196for setting the accessor to a specific value).  But you can also 
     1197call each method with no parameters to get its current value.  For 
     1198example, C<< $self->contents_file() >> returns the current value of 
     1199the contents_file attribute. 
     1200 
     1201=over 
     1202 
     1203 
     1204=item $batchconv->verbose( I<nonnegative_integer> ); 
     1205 
     1206This controls how verbose to be during batch conversion, as far as 
     1207notes to STDOUT (or whatever is C<select>'d) about how the conversion 
     1208is going.  If 0, no progress information is printed. 
     1209If 1 (the default value), some progress information is printed. 
     1210Higher values print more information. 
     1211 
     1212 
     1213=item $batchconv->index( I<true-or-false> ); 
     1214 
     1215This controls whether or not each HTML page is liable to have a little 
     1216table of contents at the top (which we call an "index" for historical 
     1217reasons).  This is true by default. 
     1218 
     1219 
     1220=item $batchconv->contents_file( I<filename> ); 
     1221 
     1222If set, should be the name of a file (in the output directory) 
     1223to write the HTML index to.  The default value is "index.html". 
     1224If you set this to a false value, no contents file will be written. 
     1225 
     1226=item $batchconv->contents_page_start( I<HTML_string> ); 
     1227 
     1228This specifies what string should be put at the beginning of 
     1229the contents page. 
     1230The default is a string more or less like this: 
     1231   
     1232  <html> 
     1233  <head><title>Perl Documentation</title></head> 
     1234  <body class='contentspage'> 
     1235  <h1>Perl Documentation</h1> 
     1236 
     1237=item $batchconv->contents_page_end( I<HTML_string> ); 
     1238 
     1239This specifies what string should be put at the end of the contents page. 
     1240The default is a string more or less like this: 
     1241 
     1242  <p class='contentsfooty'>Generated by 
     1243  Pod::Simple::HTMLBatch v3.01 under Perl v5.008 
     1244  <br >At Fri May 14 22:26:42 2004 GMT, 
     1245  which is Fri May 14 14:26:42 2004 local time.</p> 
     1246 
     1247 
     1248 
     1249=item $batchconv->add_css( $url ); 
     1250 
     1251TODO 
     1252 
     1253=item $batchconv->add_javascript( $url ); 
     1254 
     1255TODO 
     1256 
     1257=item $batchconv->css_flurry( I<true-or-false> ); 
     1258 
     1259If true (the default value), we autogenerate some CSS files in the 
     1260output directory, and set our HTML files to use those. 
     1261TODO: continue 
     1262 
     1263=item $batchconv->javascript_flurry( I<true-or-false> ); 
     1264 
     1265If true (the default value), we autogenerate a JavaScript in the 
     1266output directory, and set our HTML files to use it.  Currently, 
     1267the JavaScript is used only to get the browser to remember what 
     1268stylesheet it prefers. 
     1269TODO: continue 
     1270 
     1271=item $batchconv->no_contents_links( I<true-or-false> ); 
     1272 
     1273TODO 
     1274 
     1275=item $batchconv->html_render_class( I<classname> ); 
     1276 
     1277This sets what class is used for rendering the files. 
     1278The default is "Pod::Simple::Search".  If you set it to something else, 
     1279it should probably be a subclass of Pod::Simple::Search, and you should 
     1280C<require> or C<use> that class so that's it's loaded before 
     1281Pod::Simple::HTMLBatch tries loading it. 
     1282 
     1283=back 
     1284 
     1285 
     1286 
     1287 
     1288=head1 NOTES ON CUSTOMIZATION 
     1289 
     1290TODO 
     1291 
     1292  call add_css($someurl) to add stylesheet as alternate 
     1293  call add_css($someurl,1) to add as primary stylesheet 
     1294 
     1295  call add_javascript 
     1296 
     1297  subclass Pod::Simple::HTML and set $batchconv->html_render_class to 
     1298    that classname 
     1299  and maybe override 
     1300    $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth) 
     1301  or maybe override 
     1302    $batchconv->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth) 
     1303 
     1304 
     1305 
     1306=head1 ASK ME! 
     1307 
     1308If you want to do some kind of big pod-to-HTML version with some 
     1309particular kind of option that you don't see how to achieve using this 
     1310module, email me (C<sburke@cpan.org>) and I'll probably have a good idea 
     1311how to do it. For reasons of concision and energetic laziness, some 
     1312methods and options in this module (and the dozen modules it depends on) 
     1313are undocumented; but one of those undocumented bits might be just what 
     1314you're looking for. 
     1315 
     1316 
     1317=head1 SEE ALSO 
     1318 
     1319L<Pod::Simple>, L<Pod::Simple::HTMLBatch>, L<perlpod>, L<perlpodspec> 
     1320 
     1321 
     1322 
     1323 
     1324=head1 COPYRIGHT AND DISCLAIMERS 
     1325 
     1326Copyright (c) 2004 Sean M. Burke.  All rights reserved. 
     1327 
     1328This library is free software; you can redistribute it and/or modify it 
     1329under the same terms as Perl itself. 
     1330 
     1331This program is distributed in the hope that it will be useful, but 
     1332without any warranty; without even the implied warranty of 
     1333merchantability or fitness for a particular purpose. 
     1334 
     1335=head1 AUTHOR 
     1336 
     1337Sean M. Burke C<sburke@cpan.org> 
     1338 
     1339=cut 
     1340 
     1341 
     1342 
  • (a) /dev/null vs. (b) lib/Pod/Simple/HTMLLegacy.pm

    a b  
     1 
     2require 5; 
     3package Pod::Simple::HTMLLegacy; 
     4use strict; 
     5 
     6use vars qw($VERSION); 
     7use Getopt::Long; 
     8 
     9$VERSION = "5.01"; 
     10 
     11#-------------------------------------------------------------------------- 
     12#  
     13# This class is meant to thinly emulate bad old Pod::Html 
     14# 
     15# TODO: some basic docs 
     16 
     17sub pod2html { 
     18  my @args = (@_); 
     19   
     20  my( $verbose, $infile, $outfile, $title ); 
     21  my $index = 1; 
     22  
     23  { 
     24    my($help); 
     25 
     26    my($netscape); # dummy 
     27    local @ARGV = @args; 
     28    GetOptions( 
     29      "help"       => \$help, 
     30      "verbose!"   => \$verbose, 
     31      "infile=s"   => \$infile, 
     32      "outfile=s"  => \$outfile, 
     33      "title=s"    => \$title, 
     34      "index!"     => \$index, 
     35 
     36      "netscape!"   => \$netscape, 
     37    ) or return bad_opts(@args); 
     38    bad_opts(@args) if @ARGV; # it should be all switches! 
     39    return help_message() if $help; 
     40  } 
     41 
     42  for($infile, $outfile) { $_ = undef unless defined and length } 
     43   
     44  if($verbose) { 
     45    warn sprintf "%s version %s\n", __PACKAGE__, $VERSION; 
     46    warn "OK, processed args [@args] ...\n"; 
     47    warn sprintf 
     48      " Verbose: %s\n Index: %s\n Infile: %s\n Outfile: %s\n Title: %s\n", 
     49      map defined($_) ? $_ : "(nil)", 
     50       $verbose,     $index,     $infile,     $outfile,     $title, 
     51    ; 
     52    *Pod::Simple::HTML::DEBUG = sub(){1}; 
     53  } 
     54  require Pod::Simple::HTML; 
     55  Pod::Simple::HTML->VERSION(3); 
     56   
     57  die "No such input file as $infile\n" 
     58   if defined $infile and ! -e $infile; 
     59 
     60   
     61  my $pod = Pod::Simple::HTML->new; 
     62  $pod->force_title($title) if defined $title; 
     63  $pod->index($index); 
     64  return $pod->parse_from_file($infile, $outfile); 
     65} 
     66 
     67#-------------------------------------------------------------------------- 
     68 
     69sub bad_opts     { die _help_message();         } 
     70sub help_message { print STDOUT _help_message() } 
     71 
     72#-------------------------------------------------------------------------- 
     73 
     74sub _help_message { 
     75 
     76  join '', 
     77 
     78"[", __PACKAGE__, " version ", $VERSION, qq~] 
     79Usage:  pod2html --help --infile=<name> --outfile=<name> 
     80   --verbose --index --noindex 
     81 
     82Options: 
     83  --help         - prints this message. 
     84  --[no]index    - generate an index at the top of the resulting html 
     85                   (default behavior). 
     86  --infile       - filename for the pod to convert (input taken from stdin 
     87                   by default). 
     88  --outfile      - filename for the resulting html file (output sent to 
     89                   stdout by default). 
     90  --title        - title that will appear in resulting html file. 
     91  --[no]verbose  - self-explanatory (off by default). 
     92 
     93Note that pod2html is DEPRECATED, and this version implements only 
     94 some of the options known to older versions. 
     95For more information, see 'perldoc pod2html'. 
     96~; 
     97 
     98} 
     99 
     1001; 
     101__END__ 
     102 
     103OVER the underpass! UNDER the overpass! Around the FUTURE and BEYOND REPAIR!! 
     104 
  • (a) /dev/null vs. (b) lib/Pod/Simple/XHTML.pm

    a b  
     1=pod 
     2 
     3=head1 NAME 
     4 
     5Pod::Simple::XHTML -- format Pod as validating XHTML 
     6 
     7=head1 SYNOPSIS 
     8 
     9  use Pod::Simple::XHTML; 
     10 
     11  my $parser = Pod::Simple::XHTML->new(); 
     12 
     13  ... 
     14 
     15  $parser->parse_file('path/to/file.pod'); 
     16 
     17=head1 DESCRIPTION 
     18 
     19This class is a formatter that takes Pod and renders it as XHTML 
     20validating HTML. 
     21 
     22This is a subclass of L<Pod::Simple::Methody> and inherits all its 
     23methods. The implementation is entirely different than 
     24L<Pod::Simple::HTML>, but it largely preserves the same interface. 
     25 
     26=cut 
     27 
     28package Pod::Simple::XHTML; 
     29use strict; 
     30use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES ); 
     31$VERSION = '3.04'; 
     32use Carp (); 
     33use Pod::Simple::Methody (); 
     34@ISA = ('Pod::Simple::Methody'); 
     35 
     36BEGIN { 
     37  $HAS_HTML_ENTITIES = eval "require HTML::Entities; 1"; 
     38} 
     39 
     40my %entities = ( 
     41  q{>} => 'gt', 
     42  q{<} => 'lt', 
     43  q{'} => '#39', 
     44  q{"} => 'quot', 
     45  q{&} => 'amp', 
     46); 
     47 
     48sub encode_entities { 
     49  return HTML::Entities::encode_entities( $_[0] ) if $HAS_HTML_ENTITIES; 
     50  my $str = $_[0]; 
     51  my $ents = join '', keys %entities; 
     52  $str =~ s/([$ents])/'&' . $entities{$1} . ';'/ge; 
     53  return $str; 
     54} 
     55 
     56#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     57 
     58=head1 METHODS 
     59 
     60Pod::Simple::XHTML offers a number of methods that modify the format of 
     61the HTML output. Call these after creating the parser object, but before 
     62the call to C<parse_file>: 
     63 
     64  my $parser = Pod::PseudoPod::HTML->new(); 
     65  $parser->set_optional_param("value"); 
     66  $parser->parse_file($file); 
     67 
     68=head2 perldoc_url_prefix 
     69 
     70In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what 
     71to put before the "Foo%3a%3aBar". The default value is 
     72"http://search.cpan.org/perldoc?". 
     73 
     74=head2 perldoc_url_postfix 
     75 
     76What to put after "Foo%3a%3aBar" in the URL. This option is not set by 
     77default. 
     78 
     79=head2 title_prefix, title_postfix 
     80 
     81What to put before and after the title in the head. The values should 
     82already be &-escaped. 
     83 
     84=head2 html_css 
     85 
     86  $parser->html_css('path/to/style.css'); 
     87 
     88The URL or relative path of a CSS file to include. This option is not 
     89set by default. 
     90 
     91=head2 html_javascript 
     92 
     93The URL or relative path of a JavaScript file to pull in. This option is 
     94not set by default. 
     95 
     96=head2 html_doctype 
     97 
     98A document type tag for the file. This option is not set by default. 
     99 
     100=head2 html_header_tags 
     101 
     102Additional arbitrary HTML tags for the header of the document. The 
     103default value is just a content type header tag: 
     104 
     105  <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> 
     106 
     107Add additional meta tags here, or blocks of inline CSS or JavaScript 
     108(wrapped in the appropriate tags). 
     109 
     110=head2 default_title 
     111 
     112Set a default title for the page if no title can be determined from the 
     113content. The value of this string should already be &-escaped. 
     114 
     115=head2 force_title 
     116 
     117Force a title for the page (don't try to determine it from the content). 
     118The value of this string should already be &-escaped. 
     119 
     120=head2 html_header, html_footer 
     121 
     122Set the HTML output at the beginning and end of each file. The default 
     123header includes a title, a doctype tag (if C<html_doctype> is set), a 
     124content tag (customized by C<html_header_tags>), a tag for a CSS file 
     125(if C<html_css> is set), and a tag for a Javascript file (if 
     126C<html_javascript> is set). The default footer simply closes the C<html> 
     127and C<body> tags. 
     128 
     129The options listed above customize parts of the default header, but 
     130setting C<html_header> or C<html_footer> completely overrides the 
     131built-in header or footer. These may be useful if you want to use 
     132template tags instead of literal HTML headers and footers or are 
     133integrating converted POD pages in a larger website. 
     134 
     135If you want no headers or footers output in the HTML, set these options 
     136to the empty string. 
     137 
     138=head2 index 
     139 
     140TODO -- Not implemented. 
     141 
     142Whether to add a table-of-contents at the top of each page (called an 
     143index for the sake of tradition). 
     144 
     145 
     146=cut 
     147 
     148__PACKAGE__->_accessorize( 
     149 'perldoc_url_prefix', 
     150 'perldoc_url_postfix', 
     151 'title_prefix',  'title_postfix', 
     152 'html_css',  
     153 'html_javascript', 
     154 'html_doctype', 
     155 'html_header_tags', 
     156 'title', # Used internally for the title extracted from the content 
     157 'default_title', 
     158 'force_title', 
     159 'html_header', 
     160 'html_footer', 
     161 'index', 
     162 'batch_mode', # whether we're in batch mode 
     163 'batch_mode_current_level', 
     164    # When in batch mode, how deep the current module is: 1 for "LWP", 
     165    #  2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc 
     166); 
     167 
     168#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     169 
     170=head1 SUBCLASSING 
     171 
     172If the standard options aren't enough, you may want to subclass 
     173Pod::Simple::XHMTL. These are the most likely candidates for methods 
     174you'll want to override when subclassing. 
     175 
     176=cut 
     177 
     178sub new { 
     179  my $self = shift; 
     180  my $new = $self->SUPER::new(@_); 
     181  $new->{'output_fh'} ||= *STDOUT{IO}; 
     182  $new->accept_targets( 'html', 'HTML' ); 
     183  $new->perldoc_url_prefix('http://search.cpan.org/perldoc?'); 
     184  $new->html_header_tags('<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">'); 
     185  $new->nix_X_codes(1); 
     186  $new->codes_in_verbatim(1); 
     187  $new->{'scratch'} = ''; 
     188  return $new; 
     189} 
     190 
     191#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     192 
     193=head2 handle_text 
     194 
     195This method handles the body of text within any element: it's the body 
     196of a paragraph, or everything between a "=begin" tag and the 
     197corresponding "=end" tag, or the text within an L entity, etc. You would 
     198want to override this if you are adding a custom element type that does 
     199more than just display formatted text. Perhaps adding a way to generate 
     200HTML tables from an extended version of POD. 
     201 
     202So, let's say you want add a custom element called 'foo'. In your 
     203subclass's C<new> method, after calling C<SUPER::new> you'd call: 
     204 
     205  $new->accept_targets_as_text( 'foo' ); 
     206 
     207Then override the C<start_for> method in the subclass to check for when 
     208"$flags->{'target'}" is equal to 'foo' and set a flag that marks that 
     209you're in a foo block (maybe "$self->{'in_foo'} = 1"). Then override the 
     210C<handle_text> method to check for the flag, and pass $text to your 
     211custom subroutine to construct the HTML output for 'foo' elements, 
     212something like: 
     213 
     214  sub handle_text { 
     215      my ($self, $text) = @_; 
     216      if ($self->{'in_foo'}) { 
     217          $self->{'scratch'} .= build_foo_html($text);  
     218      } else { 
     219          $self->{'scratch'} .= $text; 
     220      } 
     221  } 
     222 
     223=cut 
     224 
     225sub handle_text { 
     226    # escape special characters in HTML (<, >, &, etc) 
     227    $_[0]{'scratch'} .= $_[0]{'in_verbatim'} ? encode_entities( $_[1] ) : $_[1] 
     228} 
     229 
     230sub start_Para     { $_[0]{'scratch'} = '<p>' } 
     231sub start_Verbatim { $_[0]{'scratch'} = '<pre><code>'; $_[0]{'in_verbatim'} = 1} 
     232 
     233sub start_head1 {  $_[0]{'scratch'} = '<h1>' } 
     234sub start_head2 {  $_[0]{'scratch'} = '<h2>' } 
     235sub start_head3 {  $_[0]{'scratch'} = '<h3>' } 
     236sub start_head4 {  $_[0]{'scratch'} = '<h4>' } 
     237 
     238sub start_item_bullet { $_[0]{'scratch'} = '<li>' } 
     239sub start_item_number { $_[0]{'scratch'} = "<li>$_[1]{'number'}. "  } 
     240sub start_item_text   { $_[0]{'scratch'} = '<li>'   } 
     241 
     242sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; $_[0]->emit } 
     243sub start_over_text   { $_[0]{'scratch'} = '<ul>'; $_[0]->emit } 
     244sub start_over_block  { $_[0]{'scratch'} = '<ul>'; $_[0]->emit } 
     245sub start_over_number { $_[0]{'scratch'} = '<ol>'; $_[0]->emit } 
     246 
     247sub end_over_bullet { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit } 
     248sub end_over_text   { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit } 
     249sub end_over_block  { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit } 
     250sub end_over_number { $_[0]{'scratch'} .= '</ol>'; $_[0]->emit } 
     251 
     252# . . . . . Now the actual formatters: 
     253 
     254sub end_Para     { $_[0]{'scratch'} .= '</p>'; $_[0]->emit } 
     255sub end_Verbatim { 
     256    $_[0]{'scratch'}     .= '</code></pre>'; 
     257    $_[0]{'in_verbatim'}  = 0; 
     258    $_[0]->emit; 
     259} 
     260 
     261sub end_head1       { $_[0]{'scratch'} .= '</h1>'; $_[0]->emit } 
     262sub end_head2       { $_[0]{'scratch'} .= '</h2>'; $_[0]->emit } 
     263sub end_head3       { $_[0]{'scratch'} .= '</h3>'; $_[0]->emit } 
     264sub end_head4       { $_[0]{'scratch'} .= '</h4>'; $_[0]->emit } 
     265 
     266sub end_item_bullet { $_[0]{'scratch'} .= '</li>'; $_[0]->emit } 
     267sub end_item_number { $_[0]{'scratch'} .= '</li>'; $_[0]->emit } 
     268sub end_item_text   { $_[0]->emit } 
     269 
     270# This handles =begin and =for blocks of all kinds. 
     271sub start_for {  
     272  my ($self, $flags) = @_; 
     273  $self->{'scratch'} .= '<div'; 
     274  $self->{'scratch'} .= ' class="'.$flags->{'target'}.'"' if ($flags->{'target'}); 
     275  $self->{'scratch'} .= '>'; 
     276  $self->emit; 
     277 
     278} 
     279sub end_for {  
     280  my ($self) = @_; 
     281  $self->{'scratch'} .= '</div>'; 
     282  $self->emit; 
     283} 
     284 
     285sub start_Document {  
     286  my ($self) = @_; 
     287  if (defined $self->html_header) { 
     288    $self->{'scratch'} .= $self->html_header; 
     289    $self->emit unless $self->html_header eq ""; 
     290  } else { 
     291    my ($doctype, $title, $metatags); 
     292    $doctype = $self->html_doctype || ''; 
     293    $title = $self->force_title || $self->title || $self->default_title || ''; 
     294    $metatags = $self->html_header_tags || ''; 
     295    if ($self->html_css) { 
     296      $metatags .= "\n<link rel='stylesheet' href='" . 
     297             $self->html_css . "' type='text/css'>"; 
     298    } 
     299    if ($self->html_javascript) { 
     300      $metatags .= "\n<script type='text/javascript' src='" . 
     301                    $self->html_javascript . "'></script>"; 
     302    } 
     303    $self->{'scratch'} .= <<"HTML"; 
     304$doctype 
     305<html> 
     306<head> 
     307<title>$title</title> 
     308$metatags 
     309</head> 
     310<body> 
     311HTML 
     312    $self->emit; 
     313  } 
     314} 
     315 
     316sub end_Document   {  
     317  my ($self) = @_; 
     318  if (defined $self->html_footer) { 
     319    $self->{'scratch'} .= $self->html_footer; 
     320    $self->emit unless $self->html_footer eq ""; 
     321  } else { 
     322    $self->{'scratch'} .= "</body>\n</html>"; 
     323    $self->emit; 
     324  } 
     325} 
     326 
     327# Handling code tags 
     328sub start_B { $_[0]{'scratch'} .= '<b>' } 
     329sub end_B   { $_[0]{'scratch'} .= '</b>' } 
     330 
     331sub start_C { $_[0]{'scratch'} .= '<code>' } 
     332sub end_C   { $_[0]{'scratch'} .= '</code>' } 
     333 
     334sub start_E { $_[0]{'scratch'} .= '&' } 
     335sub end_E   { $_[0]{'scratch'} .= ';' } 
     336 
     337sub start_F { $_[0]{'scratch'} .= '<i>' } 
     338sub end_F   { $_[0]{'scratch'} .= '</i>' } 
     339 
     340sub start_I { $_[0]{'scratch'} .= '<i>' } 
     341sub end_I   { $_[0]{'scratch'} .= '</i>' } 
     342 
     343sub start_L {  
     344  my ($self, $flags) = @_; 
     345    my $url; 
     346    if ($flags->{'type'} eq 'url') { 
     347      $url = $flags->{'to'}; 
     348    } elsif ($flags->{'type'} eq 'pod') { 
     349      $url .= $self->perldoc_url_prefix || ''; 
     350      $url .= $flags->{'to'} || ''; 
     351      $url .= '/' . $flags->{'section'} if ($flags->{'section'}); 
     352      $url .= $self->perldoc_url_postfix || ''; 
     353#    require Data::Dumper; 
     354#    print STDERR Data::Dumper->Dump([$flags]); 
     355    } 
     356 
     357    $self->{'scratch'} .= '<a href="'. $url . '">'; 
     358} 
     359sub end_L   { $_[0]{'scratch'} .= '</a>' } 
     360 
     361sub start_S { $_[0]{'scratch'} .= '<nobr>' } 
     362sub end_S   { $_[0]{'scratch'} .= '</nobr>' } 
     363 
     364sub emit { 
     365  my($self) = @_; 
     366  my $out = $self->{'scratch'} . "\n"; 
     367  print {$self->{'output_fh'}} $out, "\n"; 
     368  $self->{'scratch'} = ''; 
     369  return; 
     370} 
     371 
     372# Bypass built-in E<> handling to preserve entity encoding 
     373sub _treat_Es {}  
     374 
     3751; 
     376 
     377__END__ 
     378 
     379=head1 SEE ALSO 
     380 
     381L<Pod::Simple>, L<Pod::Simple::Methody> 
     382 
     383=head1 COPYRIGHT 
     384 
     385Copyright (c) 2003-2005 Allison Randal. 
     386 
     387This library is free software; you can redistribute it and/or modify 
     388it under the same terms as Perl itself. The full text of the license 
     389can be found in the LICENSE file included with this module. 
     390 
     391This library is distributed in the hope that it will be useful, but 
     392without any warranty; without even the implied warranty of 
     393merchantability or fitness for a particular purpose. 
     394 
     395=head1 AUTHOR 
     396 
     397Allison Randal <allison@perl.org> 
     398 
     399=cut 
     400