File Coverage

lib/Web/DataService/PodParser.pm

Criterion	Covered	Total	%
statement	9	335	2.6
branch	0	246	0.0
condition	0	77	0.0
subroutine	3	15	20.0
pod	2	8	25.0
total	14	681	2.0

#
# Web::DataService::PodParser
#
# This module implements a Pod-to-HTML formatter, subclassed from Pod::Simple.
#

use strict;

package Web::DataService::PodParser;
use Pod::Simple;
use Carp ();

our(@ISA) = qw(Pod::Simple);


# new ( options )
#
# Create a new Pod-to-HTML translator. $options must be a hashref, and may contain any of the
# following keys:
#
# target	Currently, must be 'html'; other target formats may be added later.
# html_header	If specified, this string will be used as the beginning of the HTML output. It
#		  should start with  and end with a  tag. If not specified, this
#		  module will generate the header.
# html_footer   If specified, this string will be used as the end of the HTML output.  It should
#		  include  and .  If not specified, those two closing tags will
#		  be appended to the end of the output.
# css		URL of the stylesheet for the generated documentation.  This may be site-relative,
#	          need not be absolute.  If not specified, no stylesheet link will be generated.
# page_title	Title for the generated HTML page. If the page contains a '=for wds_title'
# 	          directive, its value will override this option value.
# url_formatter A code ref to be called for translating URL specifications for output.
# debug		If true, then debugging output will be printed to STDERR
# no_tables	If true, then item lists will be translated to HTML  lists
#		  instead of HTML tables.
#

our (%FORMATTER_OPTION) = ( target => 1, html_header => 1, html_footer => 1, css =>1,
			    page_title => 1, url_formatter => 1, debug => 1, no_tables => 1 );

sub new {

    my ($class, $options) = @_;

    # Create a new Pod::Simple formatter.  We tell it to accept all targets
    # because Pod::Simple behaves strangely when it encounters targets it
    # doesn't know what to do with.  We turn off the automatically generated
    # errata section, since we will be generating this ourselves.  Finally, we
    # provide it a subroutine that will strip indentation from verbatim blocks
    # according to the indentation on the first line.

    my $new = $class->SUPER::new;

    $new->accept_target_as_text('wds_nav');
    $new->accept_targets('*');
    $new->no_errata_section(1);
    $new->strip_verbatim_indent(sub {
	my $lines = shift;
	(my $indent = $lines->[0]) =~ s/\S.*//;
	return $indent;
    });

    # Decorate the formatter with some fields relevant to this subclass.

    $new->{wds_fields} = { body => [ '' ], target => [ 'body' ],
			   listlevel => 0, listcol => 0 };

    # Add any options that were specified.

    Carp::croak "you must specify an options hash, with at least the option 'target'"
	unless ref $options eq 'HASH' && defined $options->{target};

    foreach my $k ( keys %$options )
    {
	Carp::croak "invalid option '$k'" unless $FORMATTER_OPTION{$k};

	$new->{wds_fields}{options}{$k} = $options->{$k};
    }

    Carp::croak "the only allowed target is 'html'" unless lc $options->{target} eq 'html';

    # Bless the new instance into the current package and return it.

    return bless $new;
}


# _handle_element_start ( parser, element_name, attr_hash )
#
# This method will be called automatically by the Pod::Simple parsing code at the beginning of each
# Pod element that it recognizes.

sub _handle_element_start {

    my ($parser, $element_name, $attr_hash) = @_;

    # Shortcut access the object fields for this subclass.

    my $wds = $parser->{wds_fields};

    # If debugging mode is turned on, emit debugging output.

    if ( $wds->{options}{debug} )
    {
    	print STDERR "START $element_name";

    	foreach my $k (keys %$attr_hash)
    	{
    	    print STDERR " $k=" . $attr_hash->{$k};
    	}

    	print STDERR "\n";
    }

    # If the last element found was '=for wds_table_header', the current element must be '=over'
    # or else an error will be reported.

    if ( $wds->{pending_columns} )
    {
	unless ( $element_name eq 'over-text' )
	{
	    push @{$wds->{errors}}, [ $wds->{header_source_line},
		   "improperly placed '=for wds_table_header': must immediately precede '=over'" ];
	    $wds->{header_source_line} = undef;
	    $wds->{table_no_header} = undef;
	    $wds->{pending_columns} = undef;
	}
    }

    # If we have found an ordinary paragraph and are not inside a list, generate a  tag.

    if ( $element_name eq 'Para' && ! $wds->{listlevel} )
    {
	my $attrs = qq{ class="pod_para"};

	# If we have a pending anchor, use it as the identifier for this paragraph.

	if ( defined $wds->{pending_anchor} )
	{
	    $attrs .= qq{ id="$wds->{pending_anchor}"}
		if $wds->{pending_anchor} ne '' && $wds->{pending_anchor} ne '!';
	    $wds->{pending_anchor} = undef;
	}

	$parser->add_output_text( qq{\n\n} );
    }

    # If we have found a data paragraph, the 'Data' element start/end will be surrounded by a
    # 'for' element start/end. We handle any necessary processing on the latter.

    elsif ( $element_name eq 'Data' )
    {
	# nothing to do here
    }

    # If we have found a Verbatim paragraph, generate a  tag.

    elsif ( $element_name eq 'Verbatim' )
    {
	my $attrs = qq{ class="pod_verbatim"};

	# If we have a pending anchor, use it as the identifier for this paragraph.

	if ( defined $wds->{pending_anchor} )
	{
	    $attrs .= qq{ id="$wds->{pending_anchor}"}
		if $wds->{pending_anchor} ne '' && $wds->{pending_anchor} ne '!';
	    $wds->{pending_anchor} = undef;
	}

	$parser->add_output_text( qq{\n\n} );
    }

    # If we have found =head1, =head2, etc., then start capturing heading text. We
    # will generate the appropriate HTML tag when we finish. This is necessary because the default
    # identifier for the heading tag will be the heading text.

    elsif ( $element_name =~ qr{ ^ head ( \d ) }xs )
    {
	$parser->capture_output_text('head');
    }

    # If we have found =over where the first item indicates a bullet or a number, then we are starting a
    # list. We will generate  or  as appropriate.

    elsif ( $element_name =~ qr{ ^ over-(bullet|number) $ }xs )
    {
	my $tag = $1 eq 'bullet' ? 'ul' : 'ol';
	my $class = $wds->{listlevel} > 1 ? 'pod_list2' : 'pod_list';
	my $attrs = qq{ class="$class"};

	# If we have a pending anchor, use it as the identifier for this list..

	if ( defined $wds->{pending_anchor} )
	{
	    $attrs .= qq{ id="$wds->{pending_anchor}"}
		if $wds->{pending_anchor} ne '' && $wds->{pending_anchor} ne '!';
	    $wds->{pending_anchor} = undef;
	}

	$parser->add_output_text( qq{\n\n<$tag$attrs>} );
	$wds->{listlevel}++;
    }

    # If we have found =item inside a bulleted or numbered list, then generate an  tag.

    elsif ( $element_name =~ qr{ ^ item-(bullet|number) $ }xs )
    {
	# We use a different CSS class for top-level lists than for sublists, but not a separate
	# one for sub-sublists.

	my $class = $wds->{listlevel} > 1 ? 'pod_def2' : 'pod_def';
	my $attrs = qq{ class="$class"};

	# If an explicit number was specified, use that as the item value. This allows the author
	# to explicitly number list items if desired, with automatic numbering as a fallback.

	if ( $1 =~ qr{^n}i && defined $attr_hash->{'~orig_content'} && defined $attr_hash->{number} )
	{
	    $attr_hash->{'~orig_content'} =~ qr{ (\d+) }xs;
	    if ( $1 ne $attr_hash->{number} )
	    {
		$attrs .= qq{ value="$1"};
	    }
	}

	# If we have a pending anchor, use it as the identifier for this list item.

	if ( defined $wds->{pending_anchor} )
	{
	    $attrs .= qq{ id="$wds->{pending_anchor}"}
		if $wds->{pending_anchor} ne '' && $wds->{pending_anchor} ne '!';
	    $wds->{pending_anchor} = undef;
	}

	$parser->add_output_text( qq{\n\n} );
    }

    # If we have found =over where the first item is NOT a bullet or a number, then we are
    # generating a table. Unless, that is, this formatter was instantiated with the no_tables option
    # in which case we generate a definition-list using , , and .

    elsif ( $element_name =~ qr{ ^ over-text $ }xs )
    {
	my $tag = $wds->{options}{no_tables} ? 'dl' : 'table';
	my $class = $wds->{listlevel} > 0 ? 'pod_list2' : 'pod_list';
	my $attrs = qq{ class="$class"};

	# If we have a pending anchor, use it as the identifier for this table or list.

	if ( defined $wds->{pending_anchor} )
	{
	    $attrs .= qq{ id="$wds->{pending_anchor}"}
		if $wds->{pending_anchor} ne '' && $wds->{pending_anchor} ne '!';
	    $wds->{pending_anchor} = undef;
	}

	# Emit the tag that opens the list or table.

	$parser->add_output_text( qq{\n\n<$tag$attrs>} );

	# If have a pending list of table column definitions, and this formatter was not instantiated
	# with the 'no_tables' option, then process that list.  Unless the 'no_header' flag is
	# set, generate a header row now.  We must process the column definitions regardless,
	# since they may affect the style of the ordinary table cells.

	my $table_def = { n_cols => 0, n_subs => 0 };

	$table_def->{no_header} = 1 if $wds->{table_no_header};

	if ( $wds->{pending_columns} && ! $wds->{options}{no_tables} )
	{
	    my @columns;

	    my $class = $wds->{listlevel} > 0 ? 'pod_th2' : 'pod_th';

	    # Start the header row, unless 'no_header' is in effect for this table.

	    $parser->add_output_text( qq{\n\n

	    # Process each column definition in turn.

	    foreach my $col ( @{$wds->{pending_columns}} )
	    {
		my $col_def;
		my $attrs = '';
		my $multiplicity = 1;

		$table_def->{n_cols}++;

		# If the column definition ends in /n where n is an integer, then it represents n
		# separate columns. We must prepare to generate a subheader row with that many
		# cells under this one.  In this case, the first =item subsequently encountered
		# will provide the labels for these cells. This feature is used to generate
		# response field name columns for each vocabulary when there are multiple
		# vocabularies.
		#
		# Note that /n only works on the FIRST COLUMN.

		if ( $col =~ qr{ ^ (.+) / ( \d+ ) $ }xs )
		{
		    # Strip off the suffix we just recognized.

		    $col = $1;

		    # If this is the first column, then give this cell a 'colspan' attribute equal
		    # to the column multiplicity. Also note the number of subheader cells we are
		    # expecting and set the 'expect_subheader' flag. This flag will cause the
		    # first =item paragraph we encounter to be treated specially as a list of
		    # subheader labels.

		    unless ( @columns )
		    {
			$multiplicity = $2;
			$attrs = qq{ colspan="$multiplicity"};
			$table_def->{n_subs} += $multiplicity;
			$table_def->{expect_subheader} = 1;
		    }

		    # If this is not the first column, then the suffix is ignored.
		}

		# If this is not the first column and the first column has subheaders, then
		# set the "rowspan" attribute for this header cell.

		if ( @columns && $table_def->{n_subs} )
		{
		    $attrs = qq{ rowspan="2"};
		}

		# If the column definition ends in *, then we set the 'term' flag to indicate that
		# the cells in this column should have a different style class.  Strip the * suffix
		# off the definition, and use the rest as the column name.

		if ( $col =~ qr{ ^ (.*) [*] $ }xs )
		{
		    $col = $1;
		    $col_def = { name => $col, term => 1 };
		}

		# Otherwise, just use the column definition as the column name.

		else
		{
		    $col_def = { name => $col };
		}

		# Add this column definition record to the column list for this table. If the
		# definition had an /n suffix, then add it that many times.

		push @columns, $col_def foreach 1..$multiplicity;

		# Use the remaining column definition after any suffixes have been stripped as the
		# label in the header cell.

		$parser->add_output_text( qq{$col
	    }

	    # Save the generated list of column definition records, for use in generating the
	    # body rows.

	    $table_def->{columns} = \@columns;

	    # Close the header row, if we are generating one.

	    $parser->add_output_text( qq{
	}

	# We keep a stack of table definitions, because we may be generating a table inside
	# another table cell.  In particular, this can happen when a table of acceptable values is
	# given inside the definition of a parameter or response field.

	unshift @{$wds->{table_def}}, $table_def;

	# Clear any table flags that had been set, since they are only valid for a table that
	# immediately follows them.

	$wds->{pending_columns} = undef;
	$wds->{header_source_line} = undef;
	$wds->{table_no_header} = undef;

	# Indicate that we are now inside a list/table or sublist/subtable, and note that we are
	# about to start a new row. The value of 'listcol' can be either 0 or 2. The value
	# 0 means that we are at the start of a row, and 2 means that we are in the middle of a
	# row and must close it before we start another one.

	$wds->{listlevel}++;
	$wds->{listcol} = 0;
    }

    # If we have found =item inside a list that is not bulleted or numbered, then we must start
    # capturing the item text to be processed and output when the item is done.

    elsif ( $element_name =~ qr{ ^ item-text $ }xsi )
    {
	# If the value of listcol is not 0, then we have an unclosed table row or  section and
	# must close it before we start the new item.

	if ( $wds->{listcol} > 0 )
	{
	    if ( $wds->{options}{no_tables} )
	    {
		$parser->add_output_text( qq{\n} );
	    }

	    elsif ( $wds->{listcol} == 2 )
	    {
		$parser->add_output_text( qq{\n
	    }
	}

	# Start capturing the item text. We will process it when we have it all.

	$parser->capture_output_text('item-text');
    }

    # If we have found a paragraph inside of a list, then append a  tag to the list item we are
    # currently processing. The style of a paragraph inside a list is different from an ordinary
    # paragraph not in a list. We have defined a separate style for paragraphs inside sublists.

    elsif ( $element_name eq 'Para' && $wds->{listlevel} )
    {
	my $class = $wds->{listlevel} > 1 ? 'pod_def2' : 'pod_def';
	my $attrs = qq{ class="$class"};

	# If we have a pending anchor, use it as the identifier for this paragraph.

	if ( $wds->{pending_anchor} )
	{
	    $attrs .= qq{ id="$wds->{pending_anchor}"}
		if $wds->{pending_anchor} ne '' && $wds->{pending_anchor} ne '!';
	    $wds->{pending_anchor} = undef;
	}

	$parser->add_output_text( qq{\n} );

	# Note that we are in the middle of a list item, in case this has not already been set.

	$wds->{listcol} = 2;
    }

    # If we have found an L<...> section, then we get all of its attributes with the start of the
    # element. So we can immediately generate an  tag.

    elsif ( $element_name eq 'L' )
    {
	my $href;	# this will hold the target of the link

	# The Pod::Simple code improperly handles certain kinds of links where there is also link
	# content.  I am writing this comment a few months after I wrote the code, and can no longer
	# remember what the exact problem was. At any rate, we ignore Pod::Simple's attempt to
	# parse the link content out from the link target and do it ourselves from the raw contents
	# which Pod::Simple fortunately provides us.

	if ( $attr_hash->{raw} =~ qr{ ^ (?: [^|]* [|] )? (.*) }xs )
	{
	    $href = $1;
	}

	# If there is no link content, then the link target will be given by the "to" attribute
	# passed to us by Pod::Simple. Unless the link started with "/", in which case it will be
	# in the "section" attribute instead.

	else
	{
	    $href = $attr_hash->{to} || "/$attr_hash->{section}";
	}

	# If a url_formatter attribute was provided to this formatter, then call it on the link
	# target value. This will translate something that looks like "node:a/b" into a
	# site-relative URL that links to the documentation page for node a/b; it will translate
	# something that looks like "op:a/b?foo" into a site-relative URL that will call the
	# operation a/b with argument foo. The exact form of the URL will depend on which features
	# are set for this data service.

	my $url_gen = $wds->{options}{url_formatter};
	$href = $url_gen->($href) if $href && ref $url_gen eq 'CODE';

	# If the "content-implicit" flag was set by Pod::Simple, it means that there is no link
	# content and that we should use the link target as the content.

	$wds->{override_text} = $href if $attr_hash->{'content-implicit'};

	# If the link target looks like an external URL (in other words, if it is not
	# site-relative) then add the attribute 'target="_blank"' so that it will open in a new
	# window or tab when activated.

	my $attrs = '';
	$attrs = qq{ target="_blank"} if $href =~ qr{ ^ \w+:// }xsi;

	# Output the  tag.

	$parser->add_output_text( qq{} );
    }

    # If we have found one of the other formatting sections, then we generate a  tag with
    # the appropriate class. The tricky part is that we are re-purposing part of the Pod spec by
    # defining C> to indicate the pod_term style class and B> to indicate the
    # pod_term2 style class. Otherwise, the style class will be pod_B, pod_I, etc.

    elsif ( $element_name =~ qr{ ^ ( B | I | F | C | S ) $ }xs )
    {
	my $code = $1;

	# I tried using , , etc. but decided to give it up and just us  with the
	# appropriate style classes.

	my $tag = 'span';

	# If the output generated so far ends in  or  and
	# this section has the opposite formatting code, then rewrite that tag to have the appropriate
	# style class. Then set the 'no_span' flag to indicate that we should not generate
	# at the end of this section because the enclosing element will already be generating it.

	if ( $wds->{body}[0] =~ qr{<(?:span|strong|em|code) class="pod_(.)">$}s )
	{
	    my $enclosing = $1;

	    if ( $enclosing eq 'B' && $code eq 'C' )
	    {
		$wds->{body}[0] =~ s{<[^>]+>$}{}s;
		$wds->{no_span} = 1;
	    }

	    elsif ( $enclosing eq 'C' && $code eq 'B' )
	    {
		$wds->{body}[0] =~ s{<[^>]+>$}{}s;
		$wds->{no_span} = 1;
	    }
	}

	# Otherwise, just add a new  tag.

	else
	{
	    $parser->add_output_text( qq{<$tag class="pod_$code">} );
	}
    }

    # If we have found an X<...> or Z<...> section, then we capture the text inside and throw it
    # away.

    elsif ( $element_name =~ qr{ ^ ( X | Z ) $ }xs )
    {
	$parser->capture_output_text('xz');
    }

    # If we have found a data paragraph, we will need to process its contents specially.  Note
    # that Pod::Simple uses the element name 'for' to indicate data paragraphs even if they are
    # actually bounded by =begin and =end.

    elsif ( $element_name eq 'for' )
    {
	# Ignore any colon at the beginning of the data section identifier.  Pod::Simple will have
	# already figured out whether or not it is supposed to be parsing the contents for Pod
	# elements, based on the presence or absence of a colon. There is nothing we need to do
	# differently.

	my $identifier = $attr_hash->{target};
	$identifier =~ s{^:}{};

	# Start capturing the data paragraph text.

	$parser->capture_output_text($identifier);

	# If the identifier is 'wds_nav', set a flag to indicate that the contents should be
	# processed specially. This data section is processed as Pod text even if it is not
	# preceded by a colon (see the call to accept_target_as_text in &new).

	if ( $identifier eq 'wds_nav' )
	{
	    $wds->{in_wds_nav} = 1;
	}
    }

    # Any other elements passed to us by Pod::Simple are ignored. This might not be the best
    # approach, but it is probably better than displaying error messages. If Pod::Simple ever
    # changes the set of elements that it sends to this subroutine, then (a) this module will have
    # to be updated, and (b) any users who update Pod::Simple but not Web::DataService will be
    # screwed.

    my $a = 1;	# we can stop here when debugging
}


# _handle_element_end ( parser, element_name, attr_hash )
#
# This method will be called automatically by the Pod::Simple parsing code at the end of each Pod
# element that it recognizes.

sub _handle_element_end {

    my ($parser, $element_name, $attr_hash) = @_;

    # Shortcut access the object fields for this subclass.

    my $wds = $parser->{wds_fields};

    # If debugging mode is turned on, emit debugging output.

    if ( $wds->{options}{debug} )
    {
    	print STDERR "END $element_name";

    	foreach my $k (keys %$attr_hash)
    	{
    	    print STDERR " $k=" . $attr_hash->{$k};
    	}

    	print STDERR "\n";
    }

    # If we are done processing an ordinary paragraph, generate the  tag. This is the same whether or
    # not the paragraph is in a list/table.

    if ( $element_name eq 'Para' )
    {
	$parser->add_output_text( qq{} );
    }

    # If we are done processing a verbatim paragraph, generate the  tag.

    elsif ( $element_name eq 'Verbatim' )
    {
	$parser->add_output_text( qq{} );
    }

    # If we are done processing a data paragraph, the 'Data' element start/end will be surrounded by
    # a 'for' element start/end. We handle any necessary processing on the latter.

    elsif ( $element_name eq 'Data' )
    {
	# nothing to do here
    }

    # If we are done processing a =head paragraph, then we can retrieve the captured paragraph
    # text and can generate , , etc. as appropriate.  The default identifier for a
    # heading is the heading text, which allows for URL fragments targeting a documentation
    # section, i.e. #PARAMETERS.

    elsif ( $element_name =~ qr{ ^ head ( \d ) $ }xsi )
    {
	my $level = $1;
	my $attrs = qq{ class="pod_heading"};

	# Finish capturing the paragraph text.

	my ($heading_text) = $parser->end_capture_text;

	# If we have a pending anchor, use it as the identifier for this heading unless the value
	# is '!'. Note that a value of '!' will result in no identifier at all for this heading.

	if ( $wds->{pending_anchor} )
	{
	    $attrs .= qq{ id="$wds->{pending_anchor}"} if $wds->{pending_anchor} ne '!';
	    $wds->{pending_anchor} = undef;
	}

	# Otherwise, use the heading text as the identifier.

	elsif ( $heading_text ne '' && ! $wds->{in_wds_nav} )
	{
	    $attrs .= qq{ id="$heading_text"}
	}

	# Generate the heading tag, text, and closing tag.

	$parser->add_output_text( qq{\n\n} );
	$parser->add_output_text( $heading_text );
	$parser->add_output_text( qq{} );
    }

    # If we are done processing a bulleted or numbered list, we simply need generate a closing tag
    # and decrement the list level.

    elsif ( $element_name =~ qr{ ^ over-(bullet|number) $ }xs )
    {
	my $tag = $1 eq 'bullet' ? 'ul' : 'ol';
	$parser->add_output_text( qq{\n\n} );
	$wds->{listlevel}--;
    }

    # If we are done processing a bulleted or numbered list item, we simply need to generate a
    #  tag.

    elsif ( $element_name =~ qr{ ^ item-(bullet|number) $ }xs )
    {
	$parser->add_output_text( qq{} );
    }

    # If we are done processing a list that not bulleted or numbered, then we need to generate the
    # appropriate closing tag.  But if 'listcol' is greater than zero then we are in the middle of
    # a list item and need to close it first.  We then decrement the list level.

    elsif ( $element_name eq 'over-text' )
    {
	# Generate the appropriate closing tag for the list, and for the last item if it is still
	# unclosed.

	if ( $wds->{options}{no_tables} )
	{
	    $parser->add_output_text( qq{} ) if $wds->{listcol} > 0;
	    $parser->add_output_text( qq{\n\n} );
	}

	else
	{
	    $parser->add_output_text( qq{\n
	    $parser->add_output_text( qq{\n\n