package Pod::ProjectDocs::Parser; use strict; use warnings; use base qw/Pod::Parser Class::Accessor::Fast Class::Data::Inheritable/; use Pod::ParseUtils; use URI::Escape; use File::Spec; use File::Basename; use Pod::ProjectDocs::Template; our $METHOD_REGEXP ||= qr/^(\w+).*/; BEGIN { our $HIGHLIGHTER; eval { require Syntax::Highlight::Universal; $HIGHLIGHTER = Syntax::Highlight::Universal->new; }; *highlighten = $HIGHLIGHTER ? sub { my ($self, $type, $str) = @_; $HIGHLIGHTER->highlight($type, $str); } : sub { return $_[2] }; } # most of code is borrowed from Pod::Xhtml __PACKAGE__->mk_accessors(qw/components local_modules current_files_output_path/); __PACKAGE__->mk_classdata($_) for qw/COMMANDS SEQ language/; __PACKAGE__->COMMANDS( { map { $_ => 1 } qw/pod head1 head2 head3 head4 item over back for begin end/ } ); __PACKAGE__->SEQ( { B => \&seqB, C => \&seqC, E => \&seqE, F => \&seqF, I => \&seqI, L => \&seqL, S => \&seqS, X => \&seqX, Z => \&seqZ, } ); ########## New PUBLIC methods for this class sub asString { my $self = shift; return $self->{buffer}; } sub asStringRef { my $self = shift; return \$self->{buffer}; } sub addHeadText { my $self = shift; $self->{HeadText} .= shift; } sub addBodyOpenText { my $self = shift; $self->{BodyOpenText} .= shift; } sub addBodyCloseText { my $self = shift; $self->{BodyCloseText} .= shift; } ########## Override methods in Pod::Parser ########## PUBLIC INTERFACE sub parse_from_file { my $self = shift; $self->resetMe; $self->SUPER::parse_from_file(@_); } sub parse_from_filehandle { my $self = shift; $self->resetMe; $self->SUPER::parse_from_filehandle(@_); } ########## INTERNALS sub initialize { my $self = shift; $self->{TopLinks} = qq(

Top

) unless defined $self->{TopLinks}; $self->{MakeIndex} = 1 unless defined $self->{MakeIndex}; $self->{MakeMeta} = 1 unless defined $self->{MakeMeta}; $self->{FragmentOnly} = 0 unless defined $self->{FragmentOnly}; $self->{HeadText} = $self->{BodyOpenText} = $self->{BodyCloseText} = ''; $self->{LinkParser} ||= new Pod::Hyperlink; $self->{IsFirstCommand} = 1; $self->{FirstAnchor} = "TOP"; $self->SUPER::initialize(); } sub command { my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; my $ptree = $parser->parse_text( $paragraph, $line_num ); $pod_para->parse_tree( $ptree ); $parser->parse_tree->append( $pod_para ); } sub verbatim { my ($parser, $paragraph, $line_num, $pod_para) = @_; $parser->parse_tree->append( $pod_para ); } sub textblock { my ($parser, $paragraph, $line_num, $pod_para) = @_; my $ptree = $parser->parse_text( $paragraph, $line_num ); $pod_para->parse_tree( $ptree ); $parser->parse_tree->append( $pod_para ); } sub end_pod { my $self = shift; my $ptree = $self->parse_tree; # clean up tree ready for parse foreach my $para (@$ptree) { if ($para->{'-prefix'} eq '=') { $para->{'TYPE'} = 'COMMAND'; } elsif (! @{$para->{'-ptree'}}) { $para->{'-ptree'}->[0] = $para->{'-text'}; $para->{'TYPE'} = 'VERBATIM'; } else { $para->{'TYPE'} = 'TEXT'; } foreach (@{$para->{'-ptree'}}) { unless (ref $_) { s/\n\s+$//; } } } # now loop over each para and expand any html escapes or sequences $self->_paraExpand( $_ ) foreach (@$ptree); $self->{buffer} =~ s/(\n?)<\/pre>\s*
/$1/sg; # concatenate 'pre' blocks
    1 while $self->{buffer} =~ s/
(\s+)<\/pre>/$1/sg;
    $self->{buffer} = $self->_makeIndex . $self->{buffer} if $self->{MakeIndex};
    $self->{buffer} =~ s/<<>>/$self->{FirstAnchor}/ge;
    $self->{buffer} = join "\n", qq[
], $self->{buffer}, "
"; # Expand internal L<> links to the correct sections $self->{buffer} =~ s/#<<<(.*?)>>>/'#' . $self->_findSection($1)/eg; die "gotcha" if $self->{buffer} =~ /#<<%s\n", qq(), qq(\n), _htmlEscape( $self->{doctitle} ); $headblock .= $self->_makeMeta if $self->{MakeMeta}; unless ($self->{FragmentOnly}) { $self->{buffer} = $headblock . $self->{HeadText} . "\n\n" . $self->{BodyOpenText} . $self->{buffer}; $self->{buffer} .= $self->{BodyCloseText} . "\n\n"; } # in stringmode we only accumulate the XHTML else we print it to the # filehandle unless ($self->{StringMode}) { my $out_fh = $self->output_handle; print $out_fh $self->{buffer}; } } ########## Everything else is PRIVATE sub resetMe { my $self = shift; $self->{'-ptree'} = new Pod::ParseTree; $self->{'sections'} = []; $self->{'listKind'} = []; $self->{'listHasItems'} = []; $self->{'dataSections'} = []; $self->{'section_names'} = {}; $self->{'section_ids'} = {}; foreach (qw(inList titleflag )) { $self->{$_} = 0; } foreach (qw(buffer doctitle)) { $self->{$_} = ''; } } sub parse_tree { return $_[0]->{'-ptree'}; } sub _paraExpand { my $self = shift; my $para = shift; # collapse interior sequences and strings foreach ( @{$para->{'-ptree'}} ) { $_ = (ref $_) ? $self->_handleSequence($_) : _htmlEscape( $_ ); } # the parse tree has now been collapsed into a list of strings if ($para->{TYPE} eq 'TEXT') { return if @{$self->{dataSections}}; $self->_addTextblock( join('', @{$para->{'-ptree'}}) ); } elsif ($para->{TYPE} eq 'VERBATIM') { return if @{$self->{dataSections}}; my $paragraph = "
" . join('', @{$para->{'-ptree'}}) . "\n\n
"; my $parent_list = $self->{listKind}[-1]; if ($parent_list && $parent_list == 2) { $paragraph = "
$paragraph
"; } $self->{buffer} .= $paragraph; if ($self->{titleflag} != 0) { $self->_setTitle( $paragraph ); warn "NAME followed by verbatim paragraph"; } } elsif ($para->{TYPE} eq 'COMMAND') { $self->_addCommand($para->{'-name'}, join('', @{$para->{'-ptree'}}), $para->{'-text'}, $para->{'-line'} ) } else { warn "Unrecognized paragraph type $para->{TYPE} found at $self->{_INFILE} line $para->{'-line'}\n"; } } sub _addCommand { my $self = shift; my ($command, $paragraph, $raw_para, $line) = @_; my $anchor; unless (exists $self->COMMANDS->{$command}) { warn "Unrecognized command '$command' skipped at $self->{_INFILE} line $line\n"; return; } for ($command) { /^head1/ && do { $anchor = $self->_addSection( 'head1', $paragraph ); $self->{buffer} .= qq(

$paragraph ) .($self->{TopLinks} ? $self->{TopLinks} : '').qq(

)."\n\n"; if ($anchor eq 'NAME') { $self->{titleflag} = 1; } last; }; /^head([234])/ && do { my $head_level = $1; $anchor = $self->_addSection( "head${head_level}", $paragraph ); $self->{buffer} .= qq($paragraph\n\n); (my $method = $paragraph) =~ s#$METHOD_REGEXP#$1#; if ( exists $self->{_source_code}{$method} ) { $self->{buffer} .= qq{

[Source]

\n\n};
                $self->{buffer} .= $self->{_source_code}{$method};
                $self->{buffer} .= qq{
\n\n}; } last; }; /^item/ && do { unless ($self->{inList}) { warn "Not in list at $self->{_INFILE} line $line\n"; last; } $self->{listHasItems}[-1] = 1; $self->{listCurrentParas}[-1] = 0; # is this the first item in the list? if (@{$self->{listKind}} && $self->{listKind}[-1] == 0) { my $parent_list = $self->{listKind}[-2]; # this is a sub-list if ($parent_list && $parent_list == 1) { #
    sub lists must be in an
  • [BEGIN] $self->{buffer} .= "
  • "; } elsif ($parent_list && $parent_list == 2) { #
    sub lists must be in a
    [BEGIN] $self->{buffer} .= "
    "; } if ($paragraph eq '*') { $self->{listKind}[-1] = 1; $self->{buffer} .= "
      \n"; } else { $self->{listKind}[-1] = 2; $self->{buffer} .= "
      \n"; } } else { # close last list item's tag# if ($self->{listKind}[-1] == 1) { $self->{buffer} .= "\n"; } } if (@{$self->{listKind}} && $self->{listKind}[-1] == 2) { $self->{buffer} .= qq(\t{MakeIndex} >= 2) { $anchor = $self->_addSection( 'list', $paragraph ); $self->{buffer} .= qq( id="$anchor"); } $self->{buffer} .= ">"; $self->{buffer} .= qq($paragraph\n); } last; }; /^over/ && do { $self->{inList}++; push @{$self->{listKind}}, 0; push @{$self->{listHasItems}}, 0; push @{$self->{sections}}, 'OVER'; push @{$self->{listCurrentParas}}, 0; }; /^back/ && do { if (--$self->{inList} < 0) { warn "=back commands don't balance =overs at $self->{_INFILE} line $line\n"; last; } elsif ($self->{listHasItems} == 0) { warn "empty list at $self->{_INFILE} line $line\n"; last; } elsif (@{$self->{listKind}} && $self->{listKind}[-1] == 1) { $self->{buffer} .= "\n
    \n\n"; } else { $self->{buffer} .= "
    \n"; } my $parent_list = $self->{listKind}[-2]; # this is a sub-list if ($parent_list && $parent_list == 1) { #
      sub lists must be in an
    • [END] $self->{buffer} .= "
    • \n"; } if ($parent_list && $parent_list == 2) { #
      sub lists must be in a
      [END] $self->{buffer} .= "
      \n"; } if ($self->{sections}[-1] eq 'OVER') { pop @{$self->{sections}}; } else { push @{$self->{sections}}, 'BACK'; } pop @{$self->{listHasItems}}; pop @{$self->{listKind}}; pop @{$self->{listCurrentParas}}; last; }; /^for/ && do { my ($html) = $raw_para =~ /^\s*(?:pod2)?x?html\s+(.*)/; $self->{buffer} .= $html if $html; }; /^begin/ && do { my ($ident) = $paragraph =~ /(\S+)/; push @{$self->{dataSections}}, $ident; last; }; /^end/ && do { my ($ident) = $paragraph =~ /(\S+)/; unless (@{$self->{dataSections}}) { warn "no corresponding '=begin $ident' marker at $self->{_INFILE} line $line\n"; last; } my $current_section = $self->{dataSections}[-1]; unless ($current_section eq $ident) { warn "'=end $ident' doesn't match '=begin $current_section' at $self->{_INFILE} line $line\n"; last; } pop @{$self->{dataSections}}; last; }; } if ($anchor && $self->{IsFirstCommand}) { $self->{FirstAnchor} = $anchor; $self->{IsFirstCommand} = 0; } } sub _addTextblock { my $self = shift; my $paragraph = shift; if ($self->{titleflag} != 0) { $self->_setTitle( $paragraph ); } if (! @{$self->{listKind}} || $self->{listKind}[-1] == 0) { $self->{buffer} .= "

      $paragraph

      \n\n"; } elsif (@{$self->{listKind}} && $self->{listKind}[-1] == 1) { if ($self->{listCurrentParas}[-1]++ == 0) { $self->{buffer} .= "\t
    • $paragraph"; } else { $self->{buffer} .= "\n

      $paragraph"; } } else { $self->{buffer} .= "\t\t

      $paragraph

      \n"; } } # expand interior sequences recursively, bottom up sub _handleSequence { my $self = shift; my $seq = shift; my $buffer = ''; foreach (@{$seq->{'-ptree'}}) { if (ref $_) { $buffer .= $self->_handleSequence($_); } else { $buffer .= _htmlEscape($_); } } unless (exists $self->SEQ->{$seq->{'-name'}}) { warn "Unrecognized special sequence '$seq->{'-name'}' skipped at $self->{_INFILE} line $seq->{'-line'}\n"; return $buffer; } return $self->SEQ->{$seq->{'-name'}}->($self, $buffer); } sub _makeIndexId { my $arg = shift; $arg =~ s/\W+/_/g; $arg =~ s/^_+|_+$//g; $arg =~ s/__+/_/g; $arg = substr($arg, 0, 36); return $arg; } sub _addSection { my $self = shift; my ($type, $htmlarg) = @_; return unless defined $htmlarg; my $index_id; if ($self->{section_names}{$htmlarg}) { $index_id = $self->{section_names}{$htmlarg}; } else { $index_id = _makeIndexId($htmlarg); if ($self->{section_ids}{$index_id}) { $index_id .= "-" . ++$self->{section_ids}{$index_id}; } else { $self->{section_ids}{$index_id}++; } $self->{section_names}{$htmlarg} = $index_id; } push( @{$self->{sections}}, [$type, $index_id, $htmlarg]); return $index_id; } sub _findSection { my $self = shift; my ($htmlarg) = @_; my $index_id; if ($index_id = $self->{section_names}{$htmlarg}) { return $index_id; } else { return _makeIndexId($htmlarg); } } sub _get_elem_level { my $elem = shift; if (ref($elem)) { my $type = $elem->[0]; if ($type =~ /^head(\d+)$/) { return $1; } else { return 0; } } else { return 0; } } sub _makeIndex { my $self = shift; $self->{FirstAnchor} = "TOP"; my $string = "\n

      Index

      \n
        \n"; $self->{FirstAnchor} = "TOP"; my $i = 0; my $previous_level = 0; for (my $i=0;$i< @{$self->{sections}} ; $i++) { local $_ = $self->{sections}->[$i]; my $next = ($self->{'sections'}->[$i+1] || ""); if (ref $_) { my ($type, $href, $name) = @$_; my $index_link = ""; my $next_level = _get_elem_level($next); my $this_level = _get_elem_level($_) || $previous_level; if ($this_level < $previous_level) { $index_link .= ("
      \n
    • \n" x ($previous_level - $this_level)); } $index_link .= qq(\t
    • ${name}); if ($next eq "OVER") { $index_link .= "
      \n"; } elsif ($next_level > $this_level) { $index_link .= "
      \n"; $index_link .= ("
        \n
      • \n" x ($next_level - $this_level - 1)) . "
          \n"; } else { $index_link .= "\n"; } # $index_link = qq(
            $index_link
          ) unless ($type eq 'head1'); $string .= $index_link; } elsif ($_ eq 'OVER') { $string .= qq(\t
            \n); } elsif ($_ eq 'BACK') { $string .= qq(\t
          \n\n); } $previous_level = _get_elem_level($_) || $previous_level; } $string .= ("
        \n
      • \n" x ($previous_level-1)) . "
      \n"; $string .= "
      \n\n\n"; return $string; } sub _makeMeta { my $self = shift; return qq(\t\n) . qq(\t\n) . qq(\t\n) . qq(\t\n); } sub _setTitle { my $self = shift; my $paragraph = shift; if ($paragraph =~ m/^(.+?) - /) { $self->{doctitle} = $1; } elsif ($paragraph =~ m/^(.+?): /) { $self->{doctitle} = $1; } elsif ($paragraph =~ m/^(.+?)\.pm/) { $self->{doctitle} = $1; } else { $self->{doctitle} = substr($paragraph, 0, 80); } $self->{titleflag} = 0; } sub _htmlEscape { my $txt = shift; $txt =~ s/&(?!(amp|lt|gt|quot);)/&/g; $txt =~ s//>/g; $txt =~ s/\"/"/g; return $txt; } ########## Sequence handlers sub seqI { return '' . $_[1] . ''; } sub seqB { return '' . $_[1] . ''; } sub seqC { return '' . $_[1] . ''; } sub seqF { return '' . $_[1] . ''; } sub seqZ { return ''; } sub seqL { my ($self, $link) = @_; $self->{LinkParser}->parse( $link ); my $kind = $self->{LinkParser}->type; my $string = ''; if ($kind eq 'hyperlink') { #easy, a hyperlink my $targ = _htmlEscape( $self->{LinkParser}->node ); my $text = _htmlEscape( $self->{LinkParser}->text ); $string = qq($text); } elsif ($self->{LinkParser}->page eq '') { # a link to this page # Post-process these links so we can things up to the correct sections my $targ = $self->{LinkParser}->node; my $text = _htmlEscape( $self->{LinkParser}->text ); $string = qq($text); } elsif ($kind eq 'item') { # link to the other page my $targ = $self->_resolvePage($self->{LinkParser}->page); my $node = $self->{LinkParser}->node; my $text = _htmlEscape( $self->{LinkParser}->text ); $string = qq($text); } else { my $targ = $self->_resolvePage($self->{LinkParser}->page); my $text = _htmlEscape( $self->{LinkParser}->text ); $string = qq($text); } return $string; } sub _resolvePage { my ($self, $page) = @_; my $modules = $self->local_modules->{ $self->language } || []; foreach my $module ( @$modules ) { if ( $module->{name} eq $page ) { my $targ = $self->_resolveRelPath( $module->{path} ); return $targ; } } return $self->_makeLinkToCommunity($page); } sub _makeLinkToCommunity { "abstract method" } sub _resolveRelPath { my ($self, $path ) = @_; my $curpath = $self->current_files_output_path; my ($name, $dir) = File::Basename::fileparse $curpath, qr/\.html/; return File::Spec->abs2rel($path, $dir); } sub seqS { my $text = $_[1]; $text =~ s/\s/ /g; return $text; } sub seqX { my $self = shift; my $arg = shift; my $anchor = $self->_addSection( 'head1', $arg ); return qq[$arg]; } sub seqE { my $self = shift; my $arg = shift; my $rv; if ($arg eq 'sol') { $rv = '/'; } elsif ($arg eq 'verbar') { $rv = '|'; } elsif ($arg =~ /^\d$/) { $rv = "&#$arg;"; } elsif ($arg =~ /^0?x(\d+)$/) { $rv = $1; } else { $rv = "&$arg;"; } return $rv; } sub gen_html { my($self, %args) = @_; my $doc = $args{doc}; my $components = $args{components}; my $mgr_desc = $args{desc}; open(FILE, $doc->origin) or warn $!; while() { next unless /^\s*sub\s+(\w+)/; my $method = $1; my $sub = $_; while(){ $sub .= $_; last if /^}/; } my $result = $self->highlighten("perl", $sub); $self->{_source_code}{$method} = $result; } close(FILE); $self->current_files_output_path( $doc->get_output_path ); $self->_prepare($doc, $components, $mgr_desc); # local $SIG{__WARN__} = sub { }; $self->parse_from_file($doc->origin); my $title = $self->_get_title; $doc->title($title); $self->current_files_output_path(''); return $self->asString; } sub _prepare { my($self, $doc, $components, $mgr_desc) = @_; my $charset = $doc->config->charset || 'UTF-8'; $self->{StringMode} = 1; $self->{MakeMeta} = 0; $self->{TopLinks} = $components->{arrow}->tag($doc); $self->{MakeIndex} = $doc->config->index; $self->{Lang} = $doc->config->lang; $self->initialize(); $self->addHeadText($components->{css}->tag($doc)); $self->addHeadText(qq|\n|); $self->addHeadText(q| |); $self->addBodyOpenText($self->_get_data($doc, $mgr_desc)); $self->addBodyCloseText( qq|| ); } sub _get_title { my $self = shift; my $name_node = 0; my $title = ''; foreach my $node ( @{ $self->parse_tree } ) { if ($node->{'-ptree'}[0] && $node->{'-ptree'}[0] eq 'NAME') { $name_node = 1; next; } if($name_node == 1){ $title = join "", @{ $node->{'-ptree'} }; last; } } $title =~ s/^\s*\S*\s*-\s(.*)$/$1/; return $title; } sub _get_data { my($self, $doc, $mgr_desc) = @_; my $tt = Pod::ProjectDocs::Template->new; my $text = $tt->process($doc, $doc->data, { title => $doc->config->title, desc => $doc->config->desc, name => $doc->name, outroot => $doc->config->outroot, src => $doc->get_output_src_path, mgr_desc => $mgr_desc, }); return $text if $^O ne 'MSWin32'; while ( $text =~ s|href="(.*?)\\(.*?)"|href="$1/$2"| ) { next; } return $text; } 1; __END__