File Coverage

blib/lib/Pod/POM/View/HTML.pm

Criterion	Covered	Total	%
statement	134	151	88.7
branch	33	60	55.0
condition	3	11	27.2
subroutine	30	31	96.7
pod	20	25	80.0
total	220	278	79.1

#============================================================= -*-Perl-*-
#
# Pod::POM::View::HTML
#
# DESCRIPTION
#   HTML view of a Pod Object Model.
#
# AUTHOR
#   Andy Wardley
#
# COPYRIGHT
#   Copyright (C) 2000 Andy Wardley.  All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
# REVISION
#   $Id: HTML.pm 84 2009-08-20 21:07:00Z ford $
#
#========================================================================

package Pod::POM::View::HTML;
$Pod::POM::View::HTML::VERSION = '2.00';
require 5.006;

use strict;
use warnings;

use Pod::POM::View;
use parent qw( Pod::POM::View );
use vars qw( $DEBUG $ERROR $AUTOLOAD );
use Text::Wrap;

$DEBUG   = 0 unless defined $DEBUG;
my $HTML_PROTECT = 0;
my @OVER;

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_)
	|| return;

    # initalise stack for maintaining info for nested lists
    $self->{ OVER } = [];

    return $self;
}


sub view {
    my ($self, $type, $item) = @_;

    if ($type =~ s/^seq_//) {
	return $item;
    }
    elsif (UNIVERSAL::isa($item, 'HASH')) {
	if (defined $item->{ content }) {
	    return $item->{ content }->present($self);
	}
	elsif (defined $item->{ text }) {
	    my $text = $item->{ text };
	    return ref $text ? $text->present($self) : $text;
	}
	else {
	    return '';
	}
    }
    elsif (! ref $item) {
	return $item;
    }
    else {
	return '';
    }
}


sub view_pod {
    my ($self, $pod) = @_;
    return "\n\n"
 	. $pod->content->present($self)
        . "\n\n";
}


sub view_head1 {
    my ($self, $head1) = @_;
    my $title = $head1->title->present($self);
    return "$title\n\n"
	. $head1->content->present($self);
}


sub view_head2 {
    my ($self, $head2) = @_;
    my $title = $head2->title->present($self);
    return "$title\n"
	. $head2->content->present($self);
}


sub view_head3 {
    my ($self, $head3) = @_;
    my $title = $head3->title->present($self);
    return "$title\n"
	. $head3->content->present($self);
}


sub view_head4 {
    my ($self, $head4) = @_;
    my $title = $head4->title->present($self);
    return "$title\n"
	. $head4->content->present($self);
}


sub view_over {
    my ($self, $over) = @_;
    my ($start, $end, $strip);
    my $items = $over->item();

    if (@$items) {

	my $first_title = $items->[0]->title();

	if ($first_title =~ /^\s*\*\s*/) {
	    # '=item *' =>
	    $start = "\n";
	    $end   = "\n";
	    $strip = qr/^\s*\*\s*/;
	}
	elsif ($first_title =~ /^\s*\d+\.?\s*/) {
	    # '=item 1.' or '=item 1 ' =>
	    $start = "\n";
	    $end   = "\n";
	    $strip = qr/^\s*\d+\.?\s*/;
	}
	else {
	    $start = "\n";
	    $end   = "\n";
	    $strip = '';
	}

	my $overstack = ref $self ? $self->{ OVER } : \@OVER;
	push(@$overstack, $strip);
	my $content = $over->content->present($self);
	pop(@$overstack);

	return $start
	    . $content
	    . $end;
    }
    else {
	return "\n"
	    . $over->content->present($self)
	    . "\n";
    }
}


sub view_item {
    my ($self, $item) = @_;

    my $over  = ref $self ? $self->{ OVER } : \@OVER;
    my $title = $item->title();
    my $strip = $over->[-1];

    if (defined $title) {
        $title = $title->present($self) if ref $title;
        $title =~ s/$strip// if $strip;
        if (length $title) {
            my $anchor = $title;
            $anchor =~ s/^\s*|\s*$//g; # strip leading and closing spaces
            $anchor =~ s/\W/_/g;
            $title = qq{$title};
        }
    }

    return ''
        . "$title\n"
        . $item->content->present($self)
        . "\n";
}


sub view_for {
    my ($self, $for) = @_;
    return '' unless $for->format() =~ /\bhtml\b/;
    return $for->text()
	. "\n\n";
}


sub view_begin {
    my ($self, $begin) = @_;
    return '' unless $begin->format() =~ /\bhtml\b/;
    $HTML_PROTECT++;
    my $output = $begin->content->present($self);
    $HTML_PROTECT--;
    return $output;
}


sub view_textblock {
    my ($self, $text) = @_;
    return $HTML_PROTECT ? "$text\n" : "$text\n";
}


sub view_verbatim {
    my ($self, $text) = @_;
    for ($text) {
	s/&/&/g;
	s/
	s/>/>/g;
    }
    return "$text\n\n";
}


sub view_seq_bold {
    my ($self, $text) = @_;
    return "$text";
}


sub view_seq_italic {
    my ($self, $text) = @_;
    return "$text";
}


sub view_seq_code {
    my ($self, $text) = @_;
    return "$text";
}

sub view_seq_file {
    my ($self, $text) = @_;
    return "$text";
}

sub view_seq_space {
    my ($self, $text) = @_;
    $text =~ s/\s/ /g;
    return $text;
}


sub view_seq_entity {
    my ($self, $entity) = @_;
    return "&$entity;"
}


sub view_seq_index {
    return '';
}


sub view_seq_link {
    my ($self, $link) = @_;

    # view_seq_text has already taken care of L
    if ($link =~ /^
        return $link;
    }

    # full-blown URL's are emitted as-is
    if ($link =~ m{^\w+://}s ) {
        return make_href($link);
    }

    $link =~ s/\n/ /g;   # undo line-wrapped tags

    my $orig_link = $link;
    my $linktext;
    # strip the sub-title and the following '|' char
    if ( $link =~ s/^ ([^|]+) \| //x ) {
        $linktext = $1;
    }

    # make sure sections start with a /
    $link =~ s|^"|/"|;

    my $page;
    my $section;
    if ($link =~ m|^ (.*?) / "? (.*?) "? $|x) { # [name]/"section"
        ($page, $section) = ($1, $2);
    }
    elsif ($link =~ /\s/) {  # this must be a section with missing quotes
        ($page, $section) = ('', $link);
    }
    else {
        ($page, $section) = ($link, '');
    }

    # warning; show some text.
    $linktext = $orig_link unless defined $linktext;

    my $url = '';
    if (defined $page && length $page) {
        $url = $self->view_seq_link_transform_path($page);
    }

    # append the #section if exists
    $url .= "#$section" if defined $url and
        defined $section and length $section;

    return make_href($url, $linktext);
}


# should be sub-classed if extra transformations are needed
#
# for example a sub-class may search for the given page and return a
# relative path to it.
#
# META: where this functionality should be documented? This module
# doesn't have docs section
#
sub view_seq_link_transform_path {
    my($self, $page) = @_;

    # right now the default transform doesn't check whether the link
    # is not dead (i.e. whether there is a corresponding file.
    # therefore we don't link L<>'s other than L
    # subclass to change the default (and of course add validation)

    # this is the minimal transformation that will be required if enabled
    # $page = "$page.html";
    # $page =~ s|::|/|g;
    #print "page $page\n";
    return undef;
}


sub make_href {
    my($url, $title) = @_;

    if (!defined $url) {
        return defined $title ? "$title"  : '';
    }

    $title = $url unless defined $title;
    #print "$url, $title\n";
    return qq{$title};
}




# this code has been borrowed from Pod::Html
my $urls = '(' . join ('|',
     qw{
       http
       telnet
       mailto
       news
       gopher
       file
       wais
       ftp
     } ) . ')';
my $ltrs = '\w';
my $gunk = '/#~:.?+=&%@!\-';
my $punc = '.:!?\-;';
my $any  = "${ltrs}${gunk}${punc}";

sub view_seq_text {
     my ($self, $text) = @_;

     unless ($HTML_PROTECT) {
	for ($text) {
	    s/&/&/g;
	    s/
	    s/>/>/g;
	}
     }

     $text =~ s{
        \b                           # start at word boundary
         (                           # begin $1  {
           $urls     :               # need resource and a colon
	  (?!:)                     # Ignore File::, among others.
           [$any] +?                 # followed by one or more of any valid
                                     #   character, but be conservative and
                                     #   take only what you need to....
         )                           # end   $1  }
         (?=                         # look-ahead non-consumptive assertion
                 [$punc]*            # either 0 or more punctuation followed
                 (?:                 #   followed
                     [^$any]         #   by a non-url char
                     |               #   or
                     $               #   end of the string
                 )                   #
             |                       # or else
                 $                   #   then end of the string
         )
       }{$1}igox;

     return $text;
}

sub encode {
    my($self,$text) = @_;
    require Encode;
    return Encode::encode("ascii",$text,Encode::FB_XMLCREF());
}

1;

=head1 NAME

Pod::POM::View::HTML

=head1 DESCRIPTION

HTML view of a Pod Object Model.

=head1 METHODS

=over 4

=item C

=item C

=item C

=item C

=item C

=item C

=item C

=item C

=item C

=item C

=item C

=item C

=item C

=item C

Returns the text of a CE> sequence enclosed in a Cb> element.

=item C

Returns the text of a CE> sequence enclosed in a Ci> element.

=item C

Returns the text of a CE> sequence enclosed in a Ccode> element.

=item C

=item C

=item C

Returns an empty string.  Index sequences are suppressed in HTML view.

=item C

=back

=head1 AUTHOR

Andy Wardley [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2000 Andy Wardley.  All Rights Reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut