HTML.pm Source File

BASIS r3148
00001 #============================================================= -*-Perl-*-
00002 #
00003 # Pod::POM::View::HTML
00004 #
00005 # DESCRIPTION
00006 #   HTML view of a Pod Object Model.
00007 #
00008 # AUTHOR
00009 #   Andy Wardley   <abw@kfs.org>
00010 #
00011 # COPYRIGHT
00012 #   Copyright (C) 2000 Andy Wardley.  All Rights Reserved.
00013 #
00014 #   This module is free software; you can redistribute it and/or
00015 #   modify it under the same terms as Perl itself.
00016 #
00017 # REVISION
00018 #   $Id: HTML.pm 84 2009-08-20 21:07:00Z ford $
00019 #
00020 #========================================================================
00021 
00022 package BASIS::Pod::POM::View::HTML;
00023 
00024 require 5.004;
00025 
00026 use strict;
00027 use BASIS::Pod::POM::View;
00028 use parent qw( BASIS::Pod::POM::View );
00029 use vars qw( $VERSION $DEBUG $ERROR $AUTOLOAD );
00030 use Text::Wrap;
00031 
00032 $VERSION = sprintf("%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/);
00033 $DEBUG   = 0 unless defined $DEBUG;
00034 my $HTML_PROTECT = 0;
00035 my @OVER;
00036 
00037 sub new {
00038     my $class = shift;
00039     my $self = $class->SUPER::new(@_)
00040     || return;
00041 
00042     # initalise stack for maintaining info for nested lists
00043     $self->{ OVER } = [];
00044 
00045     return $self;
00046 }
00047 
00048 
00049 sub view {
00050     my ($self, $type, $item) = @_;
00051 
00052     if ($type =~ s/^seq_//) {
00053     return $item;
00054     }
00055     elsif (UNIVERSAL::isa($item, 'HASH')) {
00056     if (defined $item->{ content }) {
00057         return $item->{ content }->present($self);
00058     }
00059     elsif (defined $item->{ text }) {
00060         my $text = $item->{ text };
00061         return ref $text ? $text->present($self) : $text;
00062     }
00063     else {
00064         return '';
00065     }
00066     }
00067     elsif (! ref $item) {
00068     return $item;
00069     }
00070     else {
00071     return '';
00072     }
00073 }
00074 
00075 
00076 sub view_pod {
00077     my ($self, $pod) = @_;
00078     return "<html>\n<body bgcolor=\"#ffffff\">\n"
00079     . $pod->content->present($self)
00080         . "</body>\n</html>\n";
00081 }
00082 
00083 
00084 sub view_head1 {
00085     my ($self, $head1) = @_;
00086     my $title = $head1->title->present($self);
00087     return "<h1>$title</h1>\n\n"
00088     . $head1->content->present($self);
00089 }
00090 
00091 
00092 sub view_head2 {
00093     my ($self, $head2) = @_;
00094     my $title = $head2->title->present($self);
00095     return "<h2>$title</h2>\n"
00096     . $head2->content->present($self);
00097 }
00098 
00099 
00100 sub view_head3 {
00101     my ($self, $head3) = @_;
00102     my $title = $head3->title->present($self);
00103     return "<h3>$title</h3>\n"
00104     . $head3->content->present($self);
00105 }
00106 
00107 
00108 sub view_head4 {
00109     my ($self, $head4) = @_;
00110     my $title = $head4->title->present($self);
00111     return "<h4>$title</h4>\n"
00112     . $head4->content->present($self);
00113 }
00114 
00115 
00116 sub view_over {
00117     my ($self, $over) = @_;
00118     my ($start, $end, $strip);
00119     my $items = $over->item();
00120 
00121     if (@$items) {
00122 
00123     my $first_title = $items->[0]->title();
00124 
00125     if ($first_title =~ /^\s*\*\s*/) {
00126         # '=item *' => <ul>
00127         $start = "<ul>\n";
00128         $end   = "</ul>\n";
00129         $strip = qr/^\s*\*\s*/;
00130     }
00131     elsif ($first_title =~ /^\s*\d+\.?\s*/) {
00132         # '=item 1.' or '=item 1 ' => <ol>
00133         $start = "<ol>\n";
00134         $end   = "</ol>\n";
00135         $strip = qr/^\s*\d+\.?\s*/;
00136     }
00137     else {
00138         $start = "<ul>\n";
00139         $end   = "</ul>\n";
00140         $strip = '';
00141     }
00142 
00143     my $overstack = ref $self ? $self->{ OVER } : \@OVER;
00144     push(@$overstack, $strip);
00145     my $content = $over->content->present($self);
00146     pop(@$overstack);
00147     
00148     return $start
00149         . $content
00150         . $end;
00151     }
00152     else {
00153     return "<blockquote>\n"
00154         . $over->content->present($self)
00155         . "</blockquote>\n";
00156     }
00157 }
00158 
00159 
00160 sub view_item {
00161     my ($self, $item) = @_;
00162 
00163     my $over  = ref $self ? $self->{ OVER } : \@OVER;
00164     my $title = $item->title();
00165     my $strip = $over->[-1];
00166 
00167     if (defined $title) {
00168         $title = $title->present($self) if ref $title;
00169         $title =~ s/$strip// if $strip;
00170         if (length $title) {
00171             my $anchor = $title;
00172             $anchor =~ s/^\s*|\s*$//g; # strip leading and closing spaces
00173             $anchor =~ s/\W/_/g;
00174             $title = qq{<a name="item_$anchor"></a><b>$title</b>};
00175         }
00176     }
00177 
00178     return '<li>'
00179         . "$title\n"
00180         . $item->content->present($self)
00181         . "</li>\n";
00182 }
00183 
00184 
00185 sub view_for {
00186     my ($self, $for) = @_;
00187     return '' unless $for->format() =~ /\bhtml\b/;
00188     return $for->text()
00189     . "\n\n";
00190 }
00191     
00192 
00193 sub view_begin {
00194     my ($self, $begin) = @_;
00195     return '' unless $begin->format() =~ /\bhtml\b/;
00196     $HTML_PROTECT++;
00197     my $output = $begin->content->present($self);
00198     $HTML_PROTECT--;
00199     return $output;
00200 }
00201     
00202 
00203 sub view_textblock {
00204     my ($self, $text) = @_;
00205     return $HTML_PROTECT ? "$text\n" : "<p>$text</p>\n";
00206 }
00207 
00208 
00209 sub view_verbatim {
00210     my ($self, $text) = @_;
00211     for ($text) {
00212     s/&/&amp;/g;
00213     s/</&lt;/g;
00214     s/>/&gt;/g;
00215     }
00216     return "<pre>$text</pre>\n\n";
00217 }
00218 
00219 
00220 sub view_seq_bold {
00221     my ($self, $text) = @_;
00222     return "<b>$text</b>";
00223 }
00224 
00225 
00226 sub view_seq_italic {
00227     my ($self, $text) = @_;
00228     return "<i>$text</i>";
00229 }
00230 
00231 
00232 sub view_seq_code {
00233     my ($self, $text) = @_;
00234     return "<code>$text</code>";
00235 }
00236 
00237 sub view_seq_file {
00238     my ($self, $text) = @_;
00239     return "<i>$text</i>";
00240 }
00241 
00242 sub view_seq_space {
00243     my ($self, $text) = @_;
00244     $text =~ s/\s/&nbsp;/g;
00245     return $text;
00246 }
00247 
00248 
00249 sub view_seq_entity {
00250     my ($self, $entity) = @_;
00251     return "&$entity;"
00252 }
00253 
00254 
00255 sub view_seq_index {
00256     return '';
00257 }
00258 
00259 
00260 sub view_seq_link {
00261     my ($self, $link) = @_;
00262 
00263     # view_seq_text has already taken care of L<http://example.com/>
00264     if ($link =~ /^<a href=/ ) {
00265         return $link;
00266     }
00267 
00268     # full-blown URL's are emitted as-is
00269     if ($link =~ m{^\w+://}s ) {
00270         return make_href($link);
00271     }
00272 
00273     $link =~ s/\n/ /g;   # undo line-wrapped tags
00274 
00275     my $orig_link = $link;
00276     my $linktext;
00277     # strip the sub-title and the following '|' char
00278     if ( $link =~ s/^ ([^|]+) \| //x ) {
00279         $linktext = $1;
00280     }
00281 
00282     # make sure sections start with a /
00283     $link =~ s|^"|/"|;
00284 
00285     my $page;
00286     my $section;
00287     if ($link =~ m|^ (.*?) / "? (.*?) "? $|x) { # [name]/"section"
00288         ($page, $section) = ($1, $2);
00289     }
00290     elsif ($link =~ /\s/) {  # this must be a section with missing quotes
00291         ($page, $section) = ('', $link);
00292     }
00293     else {
00294         ($page, $section) = ($link, '');
00295     }
00296 
00297     # warning; show some text.
00298     $linktext = $orig_link unless defined $linktext;
00299 
00300     my $url = '';
00301     if (defined $page && length $page) {
00302         $url = $self->view_seq_link_transform_path($page);
00303     }
00304 
00305     # append the #section if exists
00306     $url .= "#$section" if defined $url and
00307         defined $section and length $section;
00308 
00309     return make_href($url, $linktext);
00310 }
00311 
00312 
00313 # should be sub-classed if extra transformations are needed
00314 #
00315 # for example a sub-class may search for the given page and return a
00316 # relative path to it.
00317 #
00318 # META: where this functionality should be documented? This module
00319 # doesn't have docs section
00320 #
00321 sub view_seq_link_transform_path {
00322     my($self, $page) = @_;
00323 
00324     # right now the default transform doesn't check whether the link
00325     # is not dead (i.e. whether there is a corresponding file.
00326     # therefore we don't link L<>'s other than L<http://>
00327     # subclass to change the default (and of course add validation)
00328 
00329     # this is the minimal transformation that will be required if enabled
00330     # $page = "$page.html";
00331     # $page =~ s|::|/|g;
00332     #print "page $page\n";
00333     return undef;
00334 }
00335 
00336 
00337 sub make_href {
00338     my($url, $title) = @_;
00339 
00340     if (!defined $url) {
00341         return defined $title ? "<i>$title</i>"  : '';
00342     }
00343 
00344     $title = $url unless defined $title;
00345     #print "$url, $title\n";
00346     return qq{<a href="$url">$title</a>};
00347 }
00348 
00349 
00350 
00351 
00352 # this code has been borrowed from Pod::Html
00353 my $urls = '(' . join ('|',
00354      qw{
00355        http
00356        telnet
00357        mailto
00358        news
00359        gopher
00360        file
00361        wais
00362        ftp
00363      } ) . ')'; 
00364 my $ltrs = '\w';
00365 my $gunk = '/#~:.?+=&%@!\-';
00366 my $punc = '.:!?\-;';
00367 my $any  = "${ltrs}${gunk}${punc}";
00368 
00369 sub view_seq_text {
00370      my ($self, $text) = @_;
00371 
00372      unless ($HTML_PROTECT) {
00373     for ($text) {
00374         s/&/&amp;/g;
00375         s/</&lt;/g;
00376         s/>/&gt;/g;
00377     }
00378      }
00379 
00380      $text =~ s{
00381         \b                           # start at word boundary
00382          (                           # begin $1  {
00383            $urls     :               # need resource and a colon
00384       (?!:)                     # Ignore File::, among others.
00385            [$any] +?                 # followed by one or more of any valid
00386                                      #   character, but be conservative and
00387                                      #   take only what you need to....
00388          )                           # end   $1  }
00389          (?=                         # look-ahead non-consumptive assertion
00390                  [$punc]*            # either 0 or more punctuation followed
00391                  (?:                 #   followed
00392                      [^$any]         #   by a non-url char
00393                      |               #   or
00394                      $               #   end of the string
00395                  )                   #
00396              |                       # or else
00397                  $                   #   then end of the string
00398          )
00399        }{<a href="$1">$1</a>}igox;
00400 
00401      return $text;
00402 }
00403 
00404 sub encode {
00405     my($self,$text) = @_;
00406     require Encode;
00407     return Encode::encode("ascii",$text,Encode::FB_XMLCREF());
00408 }
00409 
00410 1;
00411 
00412 =head1 NAME
00413 
00414 Pod::POM::View::HTML
00415 
00416 =head1 DESCRIPTION
00417 
00418 HTML view of a Pod Object Model.
00419 
00420 =head1 METHODS
00421 
00422 =over 4
00423 
00424 =item C<view($self, $type, $item)>
00425 
00426 =item C<view_pod($self, $pod)>
00427 
00428 =item C<view_head1($self, $head1)>
00429 
00430 =item C<view_head2($self, $head2)>
00431 
00432 =item C<view_head3($self, $head3)>
00433 
00434 =item C<view_head4($self, $head4)>
00435 
00436 =item C<view_over($self, $over)>
00437 
00438 =item C<view_item($self, $item)>
00439 
00440 =item C<view_for($self, $for)>
00441 
00442 =item C<view_begin($self, $begin)>
00443 
00444 =item C<view_textblock($self, $textblock)>
00445 
00446 =item C<view_verbatim($self, $verbatim)>
00447 
00448 =item C<view_meta($self, $meta)>
00449 
00450 =item C<view_seq_bold($self, $text)>
00451 
00452 Returns the text of a C<BE<lt>E<gt>> sequence enclosed in a C<E<lt>b<E<gt>> element.
00453 
00454 =item C<view_seq_italic($self, $text)>
00455 
00456 Returns the text of a C<IE<lt>E<gt>> sequence enclosed in a C<E<lt>i<E<gt>> element.
00457 
00458 =item C<view_seq_code($self, $text)>
00459 
00460 Returns the text of a C<CE<lt>E<gt>> sequence enclosed in a C<E<lt>code<E<gt>> element.
00461 
00462 =item C<view_seq_file($self, $text)>
00463 
00464 =item C<view_seq_entity($self, $text)>
00465 
00466 =item C<view_seq_index($self, $text)>
00467 
00468 Returns an empty string.  Index sequences are suppressed in HTML view.
00469 
00470 =item C<view_seq_link($self, $text)>
00471 
00472 =back
00473 
00474 =head1 AUTHOR
00475 
00476 Andy Wardley E<lt>abw@kfs.orgE<gt>
00477 
00478 =head1 COPYRIGHT AND LICENSE
00479 
00480 Copyright (C) 2000 Andy Wardley.  All Rights Reserved.
00481 
00482 This module is free software; you can redistribute it and/or
00483 modify it under the same terms as Perl itself.
00484 
00485 =cut