Pod::Tree::HTML - Generate HTML from a Pod::Tree

Pod-Tree documentation Contained in the Pod-Tree distribution.

Index

Code Index:

NAME

Top

Pod::Tree::HTML - Generate HTML from a Pod::Tree

SYNOPSIS

Top

  use Pod::Tree::HTML;

  $source   =   new Pod::Tree %options;
  $source   =  "file.pod";
  $source   =   new IO::File;
  $source   = \$pod;
  $source   = \@pod;

  $dest     =   new HTML::Stream;
  $dest     =   new IO::File;
  $dest     =  "file.html";

  $html     =   new Pod::Tree::HTML $source, $dest, %options;

              $html->set_options(%options);
  @values   = $html->get_options(@keys);

              $html->translate;
              $html->translate($template);
              $html->emit_toc;
              $html->emit_body;

  $fragment = $html->escape_2396 ($section);
  $url      = $html->assemble_url($base, $page, $fragment);

REQUIRES

Top

HTML::Stream, Text::Template

DESCRIPTION

Top

Pod::Tree::HTML reads a POD and translates it to HTML. The source and destination are fixed when the object is created. Options are provided for controlling details of the translation.

The translate method does the actual translation.

For convenience, Pod::Tree::HTML can read PODs from a variety of sources, and write HTML to a variety of destinations. The new method resolves the $source and $dest arguments.

Pod::Tree::HTML can also use Text::Template to fill in an HTML template file.

Source resolution

Pod::Tree::HTML can obtain a POD from any of 5 sources. new resolves $source by checking these things, in order:

1

If $source isa POD::Tree, then the POD is taken from that tree.

2

If $source is not a reference, then it is taken to be the name of a file containing a POD.

3

If $source isa IO::File, then it is taken to be an IO::File object that is already open on a file containing a POD.

4

If $source is a SCALAR reference, then the text of the POD is taken from that scalar.

5

if $source is an ARRAY reference, then the paragraphs of the POD are taken from that array.

If $source isn't any of these things, new dies.

Destination resolution

Pod::Tree::HTML can write HTML to any of 5 destinations. new resolves $dest by checking these things, in order:

1

If $dest isa HTML::Stream, then Pod::Tree::HTML writes HTML to that stream.

2

If $dest isa IO::File, then Pod::Tree::HTML writes HTML to that file.

3

If $dest has a print method, then Pod::Tree::HTML passes HTML to that method.

4

If $dest is a SCALAR reference, then Pod::Tree::HTML writes HTML to that scalar.

5

If $dest is a string, then Pod::Tree::HTML writes HTML to the file with that name.

If $dest isn't any of these things, new dies.

METHODS

Top

$html = new Pod::Tree::HTML $source, $dest, %options

Creates a new Pod::Tree::HTML object.

$html reads a POD from $source, and writes HTML to $dest. See Source resolution and Destination resolution for details.

Options controlling the translation may be passed in the %options hash. See OPTIONS for details.

$html->set_options(%options)

Sets options controlling the translation. See OPTIONS for details.

@values = $html->get_options(@keys)

Returns the current values of the options specified in @keys. See OPTIONS for details.

$html->translate
$html->translate($template)

Translates the POD to HTML. This method should only be called once.

In the second form, $template is the name of a file containing a template. The template will be filled in by the Text::Template module. Here is a minimal template, showing example usage of all the variables that are set by Pod::Tree::HTML.

  <html>
   <head>
    <base href="{$base}">
    <link href="{$css}" rel="stylesheet" type="text/css">
    <title>{$title}</title>
   </head>
   <body bgcolor="{$bgcolor}" text="{$text}">
    {$toc}
    {$body}
   </body>
  </html>

The program fragments in the template are evaulted in the Pod::Tree::HTML package. Any variables that you set in this package will be available to your template.

When a template is used, the destination must not be an HTML::Stream object.

translate doesn't return anything. The first form always returns. The second form dies if there is an error creating or filling in the template.

$html->emit_toc
$html->emit_body

Emits the table of contents and body of the HTML document.

These methods are called automatically by translate. They are exposed in the API for applications that wish to embed the HTML inside a larger document.

Utility methods

These methods are provided for implementors who write their own link mapper objects.

$fragment = $html->escape_2396($section)

Escapes $section according to RFC 2396. For example, the section

    some section

is returned as

    some%20section
$url = $html->assemble_url($base, $page, $fragment)

Assembles $base, $page, and $fragment into a URL, of the form

    $base/$page#$fragment

Attempts to construct a valid URL, even if some of $base, $page, and $fragment are empty.

OPTIONS

Top

base => $url

Specifies a base URL for relative HTML links.

bgcolor => #rrggbb

Set the background color to #rrggbb. Default is white.

css => $url

Specifies a Cascading Style Sheet for the generated HTML page.

depth => $depth

Specifies the depth of the generated HTML page in a directory tree. See LINK MAPPING for details.

empty => 1

Causes the translate method to emit an HTML file, even if the POD is empty. If this option is not provided, then no HTML file is created for empty PODs.

hr => $level

Controls the profusion of horizontal lines in the output, as follows:

    $level   horizontal lines
    0 	     none
    1 	     between TOC and body
    2 	     after each =head1
    3 	     after each =head1 and =head2

Default is level 1.

Sets the link mapper. See LINK MAPPING for details.

text => #rrggbb

Set the text color to #rrggbb. Default is black.

title => title

Set the page title to title. If no title option is given, Pod::Tree::HTML will attempt construct a title from the second paragrah of the POD. This supports the following style:

    =head1 NAME

    ls - list contents of directory
toc => [0|1]

Includes or omits the table of contents. Default is to include the TOC.

LINKS and TARGETS

Top

Pod::Tree::HTML automatically generates HTML destination anchors for all =headn command paragraphs, and for text items in =over lists. The text of the paragraph becomes the name attribute of the anchor. Markups are ignored and the text is escaped according to RFC 2396.

For example, the paragraph

	=head1 C<Foo> Bar

is translated to 

	<h1><a name="Foo%20Bar"><code>Foo</code> Bar</a></h1>

To link to a heading, simply give the text of the heading in an L<> markup. The text must match exactly; markups may vary. Either of these would link to the heading shown above

	L</C<Foo> Bar>
	L</Foo Bar>

To generate destination anchors in other places, use the index (X<>) markup

	We can link to X<this text> this text.

and link to it as usual

	L</this text> uses the index markup.

Earlier versions of this module also emitted the content of the X<> markup as visible text. However, perlpod now specifies that X<> markups render as an empty string, so Pod::Tree::HTML has been changed to do that.

LINK MAPPING

Top

The POD specification provides the L<> markup to link from one document to another. HTML provides anchors (<a href=""></a>) for the same purpose. Obviously, a POD2HTML translator should convert the first to the second.

In general, this is a hard problem. In particular, the POD format is not powerful enough to support the kind of hyper-linking that people want in a complex documentation system.

Rather than try to be all things to all people, Pod::Tree::HTML uses a link mapper object to translate the target of a POD link to a URL. The default link mapper does a simple translation, described below. If you don't like the default translation, you can provide your own link mapper with the link_map => $link_map option.

Default

The default link mapper obtains the page and section from the target. It translates :: sequences in the page to /, and returns a URL of the form [../...][page.html][#section]

If the depth => $depth option is given, a corresponding number of ../ sequences are prepended to page.

This is a relative URL, so it will be interpreted relative to the base => $base option, if any.

Custom

To use your own link mapper, create a link mapper object and provide it to Pod::Tree::HTML with the link_map option

    sub MyMapper::new { bless {}, shift }

    sub MyMapper::url
    {
        my($mapper, $html, $target) = @_;
        ...
	return $url;
    }

    $mapper = new MyMapper;
    $html   = new Pod::Tree::HTML link_map => $mapper;

Your object should implement one method

$url = $mapper->url($html, $target)

When $html->translate() encounters an L<> markup, it calls $mapper->url. $html is the Pod::Tree::HTML object itself. $target is a Pod::Tree::Node object representing the the target of the link. See target nodes in Pod::Tree::Node for information on interpreting $target.

The url method must return a string, which will be emitted as the value of the href attribute of an HTML anchor: <a href="$url">...</a>

Pod:Tree:HTML provides the escape_2396 and assemble_url methods for convenience in implementing link mappers.

If the link mapper does not provide a url method, Pod::Tree::HTML will call map

($base, $page, $section) = $mapper->map($base, $page, $section, $depth);

Where

$base

is the URL given in the base option.

$page

is the man page named in the L<> markup.

$section

is the man page section given in the L<> markup.

$depth

is the value of the depth option.

The map method may perform arbitrary mappings on its arguments. Pod::Tree::HTML takes the returned values and constructs a URL of the form [$base/][$page.html][#$fragment]

The map method is

DIAGNOSTICS

Top

Pod::Tree::HTML::new: not enough arguments

(F) new called with fewer than 2 arguments.

Pod::Tree::HTML::new: Can't load POD from $source

(F) new couldn't resolve the $source argument. See Source resolution for details.

Pod::Tree::HTML::new: Can't write HTML to $dest

(F) new couldn't resolve the $dest argument. See Destination resolution for details.

Pod::Tree::HTML::new: Can't open $dest: $!

(F) The destination file couldn't be opened.

SEE ALSO

Top

perl(1), Pod::Tree, Pod::Tree::Node, Text::Template

AUTHOR

Top

Steven McDougall, swmcd@world.std.com

COPYRIGHT

Top

Copyright (c) 1999-2009 by Steven McDougall. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

Pod-Tree documentation Contained in the Pod-Tree distribution. 
# Copyright (c) 1999-2007 by Steven McDougall.  This module is free
# software; you can redistribute it and/or modify it under the same
# terms as Perl itself.

use strict;
use HTML::Stream;
use IO::File;
use IO::String;
use Pod::Tree;
use Text::Template;


package Pod::Tree::BitBucket;

sub new      { bless {}, shift }
sub AUTOLOAD { shift }


package Pod::Tree::StrStream;

sub new
{
    my($class, $ref) = @_;

    if ($ref)
    {
	return bless $ref, $class
    }
    else
    {
	my $st = '';
	return bless \$st, $class;
    }
}

sub print
{
    my $st = shift;
    $$st  .= join('', @_);
}

sub get
{
    my $st = shift;
    my $s  = $$st;
    $$st   = '';
    $s
}


package Pod::Tree::HTML;

use constant BGCOLOR => '#ffffff';
use constant TEXT    => '#000000';

our $VERSION = '1.10';

sub new
{
    my($class, $source, $dest, %options) = @_;
    defined $dest or die "Pod::Tree::HTML::new: not enough arguments\n";

    my $tree         = _resolve_source($source);
    my($fh, $stream) = _resolve_dest  ($dest  , $tree, \%options);

    my $options = { bgcolor     => BGCOLOR,
		    depth       => 0,
		    hr          => 1,
		    link_map    => Pod::Tree::HTML::LinkMap->new(),
		    text        => TEXT,
		    toc         => 1,
		    };

    my $HTML = { tree        => $tree,
		 root        => $tree->get_root,
		 stream      => $stream,
		 fh          => $fh,
		 text_method => 'text',
		 options     => $options,
		 };

    bless $HTML, $class;

    $HTML->set_options(%options);
    $HTML
}


sub _resolve_source
{
    my $source = shift;
    my $ref    = ref $source;
    local *isa = \&UNIVERSAL::isa;

    isa($source, 'Pod::Tree') and return $source;

    my $tree = new Pod::Tree;
    not $ref		     and $tree->load_file      ( $source);
    isa($source, 'IO::File') and $tree->load_fh	       ( $source);
    $ref eq 'SCALAR'         and $tree->load_string    ($$source);
    $ref eq 'ARRAY'          and $tree->load_paragraphs( $source);

    $tree->loaded or 
	die "Pod::Tree::HTML::_resolve_source: Can't load POD from $source\n";

    $tree
}


sub _resolve_dest
{
    my($dest, $tree, $options) = @_;

    $tree->has_pod or $options->{empty} or
	return (undef, new Pod::Tree::BitBucket);

    local *isa = \&UNIVERSAL::isa;
    local *can = \&UNIVERSAL::can;

    isa($dest, 'HTML::Stream') and return (undef, 		   $dest);
    isa($dest, 'IO::File'    ) and return ($dest, new HTML::Stream $dest);
    can($dest, 'print'       ) and return ($dest, new HTML::Stream $dest);

    if (ref $dest eq 'SCALAR')
    {
	my $fh = new IO::String $$dest;
	return ($fh, new HTML::Stream $fh);
    }

    if (ref $dest eq '' and $dest)
    {
	my $fh = new IO::File;
	$fh->open($dest, '>') or die "Pod::Tree::HTML::new: Can't open $dest: $!\n";
	return ($fh, new HTML::Stream $fh);
    }

    die "Pod::Tree::HTML::_resolve_dest: Can't write HTML to $dest\n";
}


sub set_options
{
    my($html, %options) = @_;

    my($key, $value);
    while (($key, $value) = each %options)
    {
	$html->{options}{$key} = $value;
    }
}


sub get_options
{
    my($html, @options) = @_;

    map { $html->{options}{$_} } @options
}


sub get_stream { shift->{stream} }


sub translate
{
    my($html, $template) = @_;

    if ($template)
    {
	$html->_template($template);
    }
    else
    {
	$html->_translate;
    }
}


sub _translate
{
    my $html    = shift;
    my $stream  = $html->{stream};
    my $bgcolor = $html->{options}{bgcolor};
    my $text 	= $html->{options}{text};
    my $title   = $html->_make_title;
    my $base    = $html->{options}{base};
    my $css     = $html->{options}{css};

    $stream->HTML->HEAD;

    defined $title and $stream->TITLE->text($title)->_TITLE;
    defined $base  and $stream->BASE(href => $base);
    defined $css   and $stream->LINK(href => $css,
				     type => "text/css",
				     rel  => "stylesheet");

    $stream->_HEAD
	   ->BODY(BGCOLOR => $bgcolor, TEXT => $text);

    $html->emit_toc;
    $html->emit_body;

    $stream->nl
	   ->_BODY
	   ->_HTML
}


sub _template
{
    my ($html, $tSource) = @_;

    my 	$fh	    = $html->{fh};
    my  $sStream    = new Pod::Tree::StrStream;
    $html->{stream} = new HTML::Stream $sStream;

    our $bgcolor = $html->{options}{bgcolor};
    our $text 	 = $html->{options}{text};
    our $title   = $html->_make_title;
    our $base    = $html->{options}{base};
    our $css     = $html->{options}{css};

    $html->emit_toc;
    our $toc = $sStream->get;

    $html->emit_body;
    our $body = $sStream->get;

    my $template = new Text::Template SOURCE => $tSource or
	die "Can't create Text::Template object: $Text::Template::ERROR\n";

    $template->fill_in(OUTPUT => $fh) or
	die $Text::Template::ERROR;
}


sub _make_title
{
    my $html  = shift;

    my $title = $html->{options}{title};
    defined $title and return $title;

    my $children = $html->{root}->get_children;
    my $node1;
    my $i = 0;
    for my $child (@$children)
    {
	is_pod $child or next;
	$i++ and $node1 = $child;
	$node1 and last;
    }

    $node1 or return undef;

    my $text = $node1->get_deep_text;
    ($title) = split m(\s+-), $text;

    $title  or return undef;      # to quiet -w
    $title =~ s(\s+$)();

    $title
}


sub emit_toc
{
    my $html = shift;
    $html->{options}{toc} or return;

    my $root  = $html->{root};
    my $nodes = $root->get_children;
    my @nodes = @$nodes;

    $html->_emit_toc_1(\@nodes);

    $html->{options}{hr} > 0 and $html->{stream}->HR;
}


sub _emit_toc_1
{
    my($html, $nodes) = @_;
    my $stream = $html->{stream};

    $stream->UL;

    while (@$nodes)
    {
	my $node = $nodes->[0];
	is_c_head2 $node and $html->_emit_toc_2   ($nodes), next;
	is_c_head1 $node and $html->_emit_toc_item($node );
	shift @$nodes;
    }

    $stream->_UL;
}


sub _emit_toc_2
{
    my($html, $nodes) = @_;
    my $stream = $html->{stream};

    $stream->UL;

    while (@$nodes)
    {
	my $node = $nodes->[0];
	is_c_head1 $node and last;
	is_c_head2 $node and $html->_emit_toc_item($node);
	shift @$nodes;
    }

    $stream->_UL;
}


sub _emit_toc_item
{
    my($html, $node) = @_;
    my $stream = $html->{stream};
    my $target = $html->_make_anchor($node);

    $stream->LI->A(HREF => "#$target");
    $html->_emit_children($node);
    $stream->_A;
}


sub emit_body
{
    my $html = shift;
    my $root = $html->{root};
    $html->_emit_children($root);
}


sub _emit_children
{
    my($html, $node) = @_;

    my $children = $node->get_children;

    for my $child (@$children)
    {
	$html->_emit_node($child);
    }
}


sub _emit_siblings
{
    my($html, $node) = @_;

    my $siblings = $node->get_siblings;

    if (@$siblings==1 and $siblings->[0]{type} eq 'ordinary')
    {
	# don't put <p></p> around a single ordinary paragraph
	$html->_emit_children($siblings->[0]);
    }
    else
    {
	for my $sibling (@$siblings)
	{
	    $html->_emit_node($sibling);
	}
    }
    
}


sub _emit_node
{
    my($html, $node) = @_;
    my $type = $node->{type};

    for ($type)
    {
	/command/  and $html->_emit_command ($node);
	/for/      and $html->_emit_for     ($node);
	/item/     and $html->_emit_item    ($node);
	/list/     and $html->_emit_list    ($node);
	/ordinary/ and $html->_emit_ordinary($node);
	/sequence/ and $html->_emit_sequence($node);
	/text/     and $html->_emit_text    ($node);
	/verbatim/ and $html->_emit_verbatim($node);
    }
}


my %HeadTag = ( head1 => { 'open' => 'H1', 'close' => '_H1', level => 1 },
	        head2 => { 'open' => 'H2', 'close' => '_H2', level => 2 },
	        head3 => { 'open' => 'H3', 'close' => '_H3', level => 3 },
	        head4 => { 'open' => 'H4', 'close' => '_H4', level => 4 } );

sub _emit_command
{
    my($html, $node) = @_;
    my $stream   = $html->{stream};
    my $command  = $node->get_command;
    my $head_tag = $HeadTag{$command};
    $head_tag or return;
    my $anchor   = $html->_make_anchor($node);

    $html->_emit_hr($head_tag->{level});

    my $tag;
    $tag = $head_tag->{'open'};
    $stream->$tag()->A(NAME => $anchor);

    $html->_emit_children($node);

    $tag = $head_tag->{'close'};
    $stream->_A->$tag();
}


sub _emit_hr
{
    my($html, $level) = @_;
    $html->{options}{hr} > $level or return;
    $html->{skip_first}++ or return;
    $html->{stream}->HR;
}


sub _emit_for
{
    my($html, $node) = @_;
    
    my $interpreter = lc $node->get_arg;
    my $emit        = "_emit_for_$interpreter";

    $html->$emit($node) if $html->can($emit);
}

sub _emit_for_html
{
    my($html, $node) = @_;

    my $stream = $html->{stream};
    $stream->P;
    $stream->io->print($node->get_text);
    $stream->_P;
}

sub _emit_for_image
{
    my($html, $node) = @_;

    my $stream = $html->{stream};
    my $link    = $node->get_text;
       $link    =~ s(\s+$)();

    $stream->IMG(src => $link);
}


sub _emit_item
{
    my($html, $node) = @_;

    my $stream    = $html->{stream};
    my $item_type = $node->get_item_type;
    for ($item_type)
    {
	/bullet/ and do
	{
	    $stream->LI();
	    $html->_emit_siblings($node);
	    $stream->_LI();
	};

	/number/ and do
	{
	    $stream->LI();
	    $html->_emit_siblings($node);
	    $stream->_LI();
	};

	/text/   and do
	{
	    my $anchor = $html->_make_anchor($node);
	    $stream->DT->A(NAME => "$anchor");
	    $html->_emit_children($node);
	    $stream->_A->_DT->DD;
	    $html->_emit_siblings($node);
	    $stream->_DD;
	};
    }

}


my %ListTag  = (bullet => { 'open' => 'UL', 'close' => '_UL' },
		number => { 'open' => 'OL', 'close' => '_OL' },
		text   => { 'open' => 'DL', 'close' => '_DL' } );

sub _emit_list
{
    my($html, $node) = @_;
    my($list_tag, $tag);    # to quiet -w, see beloew

    my $stream    = $html->{stream};
    my $list_type = $node->get_list_type;

    $list_type and $list_tag = $ListTag{$list_type};
    $list_tag  and $tag      = $list_tag->{'open'};
    $tag and $stream->$tag();

    $html->_emit_children($node);
    
    $list_tag and $tag = $list_tag->{'close'};
    $tag and $stream->$tag();
}


sub _emit_ordinary
{
    my($html, $node) = @_;
    my $stream = $html->{stream};

    $stream->P;
    $html->_emit_children($node);
    $stream->_P;
}


sub _emit_sequence
{
    my($html, $node) = @_;

    for ($node->get_letter)
    {
	/I|B|C|F/ and $html->_emit_element($node), last;
	/S/       and $html->_emit_nbsp   ($node), last;
	/L/       and $html->_emit_link   ($node), last;
	/X/       and $html->_emit_index  ($node), last;
	/E/       and $html->_emit_entity ($node), last;
    }
}


my %ElementTag = (I => { 'open' => 'I'   , 'close' => '_I'    },
		  B => { 'open' => 'B'   , 'close' => '_B'    },
		  C => { 'open' => 'CODE', 'close' => '_CODE' },
		  F => { 'open' => 'I'   , 'close' => '_I'    } );

sub _emit_element
{
    my($html, $node) = @_;

    my $letter = $node->get_letter;
    my $stream = $html->{stream};

    my $tag;
    $tag = $ElementTag{$letter}{'open'};
    $stream->$tag();
    $html->_emit_children($node);
    $tag = $ElementTag{$letter}{'close'};
    $stream->$tag();
}


sub _emit_nbsp
{
    my($html, $node) = @_;

    my $old_method = $html->{text_method};
    $html->{text_method} = 'text_nbsp';
    $html->_emit_children($node);
    $html->{text_method} = $old_method;
}


sub _emit_link
{
    my($html, $node) = @_;

    my $stream = $html->{stream};
    my $target = $node->get_target;
    my $domain = $target->get_domain;
    my $method = "make_${domain}_URL";
    my $url    = $html->$method($target);

    $stream->A(HREF=>$url);
    $html->_emit_children($node);
    $stream->_A;
}

sub make_POD_URL
{
    my($html, $target) = @_;

    my $link_map = $html->{options}{link_map};

    return $link_map->url($html, $target) if $link_map->can("url");

    $html->make_mapped_URL($target)
}


sub make_mapped_URL
{
    my($html, $target) = @_;

    my $link_map = $html->{options}{link_map};
    my $base     = $html->{options}{base} || '';
    my $page     = $target->get_page;
    my $section  = $target->get_section;
    my $depth    = $html->{options}{depth};

    ($base, $page, $section) = $link_map->map($base, $page, $section, $depth);

       $base     =~ s(/$)();
       $page    .= '.html' if $page;
    my $fragment = $html->escape_2396($section);
    my $url      = $html->assemble_url($base, $page, $fragment);

    $url
}

sub make_HTTP_URL
{
    my($html, $target) = @_;

    $target->get_page
}


sub _emit_index
{
    my($html, $node) = @_;

    my $stream = $html->{stream};
    my $anchor = $html->_make_anchor($node);
    $stream->A(NAME=>$anchor)->_A;
}


sub _emit_entity
{
    my($html, $node) = @_;

    my $stream = $html->{stream};
    my $entity  = $node->get_deep_text;
    $stream->ent($entity);
}


sub _emit_text
{
    my($html, $node) = @_;
    my $stream       = $html->{stream};
    my $text         = $node->get_text;
    my $text_method  = $html->{text_method};

    $stream->$text_method($text);
}


sub _emit_verbatim
{
    my($html, $node) = @_;
    my $stream = $html->{stream};
    my $text   = $node->get_text;
       $text   =~ s(\n\n$)();

    $stream->PRE->text($text)->_PRE;
}


sub _make_anchor
{
    my($html, $node) = @_;
    my $text = $node->get_deep_text;
       $text =~ s(   \s*\n\s*/  )( )xg;  # close line breaks
       $text =~ s( ^\s+ | \s+$  )()xg;   # clip leading and trailing WS
       $html->escape_2396($text)
}

 
sub bin { oct '0b' . join '', @_ }

my @LinkFormat = ( sub { my($b,$p,$f)=@_; ""         },
		   sub { my($b,$p,$f)=@_;      "#$f" },
                   sub { my($b,$p,$f)=@_;    "$p"    },
                   sub { my($b,$p,$f)=@_;    "$p#$f" },
                   sub { my($b,$p,$f)=@_; "$b/"      },
                   sub { my($b,$p,$f)=@_;      "#$f" },
                   sub { my($b,$p,$f)=@_; "$b/$p"    },
                   sub { my($b,$p,$f)=@_; "$b/$p#$f" } );

sub assemble_url
{
    my($html, $base, $page, $fragment) = @_;

    my $i    = bin map { length($_) ? 1 : 0 } ($base, $page, $fragment);
    my $url  = $LinkFormat[$i]($base, $page, $fragment);

    $url
}

sub escape_2396
{
    my($html, $text) = @_;
    $text =~ s(([^\w\-.!~*'()]))(sprintf("%%%02x", ord($1)))eg;
    $text
}


package Pod::Tree::HTML::LinkMap;

sub new
{
    my $class = shift;
    bless {}, $class
}

sub url
{
    my($link_map, $html, $target) = @_;

    my $depth    = $html->{options}{depth};
    my $base     = join '/', ('..') x $depth;

    my $page     = $target->get_page;
       $page     =~ s(::)(/)g;
       $page    .= '.html' if $page;

    my $section  = $target->get_section;
    my $fragment = $html->escape_2396 ($section);

    my $url      = $html->assemble_url($base, $page, $fragment);
    $url
}


__END__