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(
) 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} =~ /#<<;
my $headblock = sprintf "%s\n%s\n\t%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{
\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 = "\nIndex
\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;
$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;
}
1;
__END__