# -*-perl-*-
# $Id: html.wrt 772 2006-01-29 22:15:11Z marknodine $
# Copyright (C) 2002-2005 Freescale Semiconductor, Inc.
# Distributed under terms of the Perl license, which is the disjunction of
# the GNU General Public License (GPL) and the Artistic License.
# Writer for html files
=pod
=begin reST
=begin Description
This writer creates HTML output.
It uses the following output defines:
-W attribution=<dash|parentheses|parens|none>
Specifies how the attribution of a block quote
is to be formatted (default is 'dash').
-W body-attr=<text> Specifies attributes to be passed to the <body>
tag (default is '').
-W cloak-email-addresses[=<0|1>]
Enables cloaking of email addresses to keep
spambots from harvesting email addresses.
Default is 0.
-W colspecs[=<0|1>] Output colgroup width sections in tables based upon
the relative widths of the table columns in the
source. Default is 1.
-W embed-stylesheet[=<0|1>]
Embed the primary stylesheet verbatim in the
HTML output if possible. Stylesheets with
http: URLs are not embeddable. If prest is
installed with no default URL specified, the
default stylesheet is always embedded. Default
is 0.
-W field-limit=<num> Specify the maximum width (in characters) for
field names in field lists. Longer fields will
span an entire row of the table used to render
the field list. Default is 14 characters.
-W footnote-backlinks=<0|1>
Enable backlinks from footnotes and citations
to their references if 1 (default is 1).
-W footnote-references=<superscript|brackets>
Format for footnote references. Default is
"superscript".
-W html-prolog=<0|1>
Generate file prolog for XHTML if 0 or
HTML if 1 (default is 0).
-W image-exts=<ext-list>
A comma-separated list of "ext1=ext2" pairs where
any URI with extension ext1 has it mapped to ext2.
This option allows using a single document
source with multiple writers by using whatever
figure extension is appropriate for a given writer.
-W link-target=<expr> An expression that determines what the target
frame will be in link references. The
link URL is available in ``$_`` so that the
target frame can depend upon the URL
(default is "").
-W option-limit=<num> Specify the maximum width (in characters) for
options in option lists. Longer options will
span an entire row of the table used to render
the option list. Default is 14 characters.
-W stylesheet[=<0|URL|file>]
Specify a URL or file for the primary stylesheet
in the HTML header, or 0 or 'none' to omit the
primary stylesheet. A file or "file:" URL
should be either a full path or a path relative
to where the HTML file will be served. The
stylesheet will be a link unless
-W embed-stylesheet is specified and the
stylesheet is embeddable. Defaults to
"${Text::Restructured::PrestConfig::DEFAULTCSS}"
-W stylesheet2=file
Specify a file to be embedded in the HTML
header as a secondary stylesheet.
-W target-tag=<a|span>
The HTML tag to use for target definitions (default
is "a").
=end Description
=end reST
=cut
sub BEGIN = {
# My -W flags
use vars qw($attribution $body_attr $cloak_email_addresses $colspecs
$embed_stylesheet $field_limit $footnote_backlinks
$footnote_references $html_prolog $image_exts
$link_target $option_limit $stylesheet $stylesheet2
$target_tag);
# Static globals
use vars qw($DOM);
*DOM = \'Text::Restructured::DOM'; #';
# Run-time globals
use vars qw($HAS_CONTENTS $TARGET_FRAME $FOOTER $HEADER @HEAD @HEAD_INFO
%IMAGE_EXTS $IMAGE_EXT_RE %USED_DEFAULT $DOCTYPE);
# Defaults for -W flags
$attribution = 'dash' unless defined $attribution;
$body_attr = '' unless defined $body_attr;
$cloak_email_addresses = '' unless defined $cloak_email_addresses;
$colspecs = 1 unless defined $colspecs;
# Note: $stylesheet will be 'none' only if DEFAULTCSS is
$stylesheet = '' unless defined $stylesheet;
$stylesheet = $stylesheet =~ /^(0|none)$/i ? 0 :
$stylesheet ? $stylesheet :
$Text::Restructured::PrestConfig::DEFAULTCSS;
my $embeddable = $stylesheet && $stylesheet !~ /^http:/;
$embed_stylesheet = $stylesheet =~ /^none$/ ||
$embed_stylesheet && $embeddable;
$field_limit = 14 unless defined $field_limit;
$footnote_backlinks = 1 unless defined $footnote_backlinks;
$footnote_references = 'superscript'
unless defined $footnote_references;
$html_prolog = 0 unless defined $html_prolog;
$link_target = "''" unless defined $link_target;
$option_limit = 14 unless defined $option_limit;
$target_tag = "a" unless defined $target_tag;
$image_exts = '' unless defined $image_exts;
%IMAGE_EXTS = split /[,=]/, $image_exts;
$IMAGE_EXT_RE = join '|', map("\Q$_", keys %IMAGE_EXTS);
$DOCTYPE = $html_prolog ? << "EOPROLOG1" : << "EOPROLOG2" ;
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
EOPROLOG1
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
EOPROLOG2
;
}
# Creates a default HTML string
sub Default {
my ($dom, $str) = @_;
my $attr = GetAttr($dom);
if (($dom->{attr}{'xml:space'} || '') eq 'preserve') {
$str = qq(<pre class="$dom->{tag}">$str</pre>\n\n);
}
my $newstr = "<$dom->{tag}$attr>$str</$dom->{tag}>";
# Annotate the DOM with our content string
$dom->{_html}{str} = $str;
return $newstr;
}
# Creates a string from a reference to an attribute hash. Attribute
# values may be either scalars or array references.
# Arguments: hash reference
# Returns: string
sub MakeAttrList {
my ($attr) = @_;
return '' unless defined $attr && %$attr;
return ' ' . join(' ', map($_ . (! defined $attr->{$_} ? '' :
ref($attr->{$_}) eq 'ARRAY' ?
qq(="@{$attr->{$_}}") :
qq(="$attr->{$_}")),
sort keys %$attr));
}
# Returns the attribute string for a DOM based upon its attr and _html,attr
# elements.
# Arguments: DOM object
# Returns: string
sub GetAttr {
my ($dom) = @_;
# The only thing taken from attr is {classes}, which is translated to
# 'class' under {_html}.
$dom->{_html}{attr}{class} = $dom->{attr}{classes}
if $dom->{attr}{classes} && @{$dom->{attr}{classes}};
my $attr_list = $dom->{_html}{attr} ?
MakeAttrList(\%{$dom->{_html}{attr}}) : '';
delete $dom->{_html}{attr}{class};
return $attr_list;
}
# Returns all the "paragraphs" from the DOM's contents (everything except
# comments, targets, substitution_definitions
# Arguments: DOM object
# Returns: list of DOM objects
sub Paras {
my ($dom) = @_;
grep($_->{tag} !~ /^(comment|target|substitution_definition)$/,
$dom->contents());
}
# Encodes HTML-specific characters
# Arguments: string
# Returns: substituted string
sub EncodeHTML {
my ($s) = @_;
$s =~ s/&/&/g;
$s =~ s/</</g;
$s =~ s/>/>/g;
$s =~ s/[\xa0\xc2]/ /g;
# $s =~ s/\"/"/g; ######## FIX
$s =~ s/\@/&\#64;/g; ######## FIX
return $s;
}
# This phase fixes all the attribute values to have characters that are
# safe for HTML files
phase FIXATTR {
sub .* = { # FIXATTR
my ($dom, $str) = @_;
my $attr;
foreach $attr (keys %{$dom->{attr}}) {
if (ref($dom->{attr}{$attr}) eq 'ARRAY') {
@{$dom->{attr}{$attr}} =
map(EncodeHTML($_), @{$dom->{attr}{$attr}});
}
elsif (defined $dom->{attr}{$attr}) {
$dom->{attr}{$attr} =
EncodeHTML($dom->{attr}{$attr});
}
}
return;
}
}
# This phase preprocesses the file.
phase PREPROCESS {
sub \#PCDATA = { # PREPROCESS
my ($dom) = @_;
my $parent = $dom->parent();
return $parent->{tag} eq 'raw' ? $dom->{text} :
EncodeHTML($dom->{text});
}
sub document = { # PREPROCESS
my ($dom) = @_;
my $nesting = 0;
# Compute the nesting levels for titles
$dom->Recurse
(sub {
my ($dom, $when) = @_;
if ($dom->{tag} eq 'section') {
$nesting += $when eq 'pre' ? 1 : -1;
}
elsif ($dom->{tag} eq 'title') {
$dom->{_html}{nesting} = $nesting;
}
return 0;
}, 'both');
my $target_frame = "sub { (\$_)=\@_; $link_target}";
$TARGET_FRAME = eval($target_frame);
die "Cannot parse link target $link_target: $@" if $@;
return;
}
sub docinfo = { # PREPROCESS
my ($dom, $str) = @_;
# Flatten Authors if it exists
$dom->Reshape(sub {
my ($dom) = @_;
return $dom->contents() if ($dom->{tag} eq 'authors');
return $dom;
});
return;
}
sub author|date|organization|copyright = { # PREPROCESS
my ($dom, $str) = @_;
chomp $str;
my $headstr = $str;
$headstr =~ s/\n/ /g;
# Remove any HTML tags within it
$headstr =~ s/<[^>]*>//g;
push (@HEAD_INFO, [$dom->{tag}, $headstr]);
return $str;
}
sub meta = { # PREPROCESS
my ($dom) = @_;
my $attr = MakeAttrList($dom->{attr});
push (@HEAD_INFO, "<meta$attr />\n");
return;
}
sub reference = { # PREPROCESS
my ($dom, $str) = @_;
chomp $str;
#### FIX
use vars qw($FIRST_REFERENCE);
push (@{$dom->{attr}{classes}}, 'first', 'last')
if ! $FIRST_REFERENCE++;
return;
}
sub authors = { # PREPROCESS
return;
}
sub literal = { # PREPROCESS
my ($dom, $str) = @_;
PreprocessLiteral($dom);
return;
sub PreprocessLiteral {
my ($dom) = @_;
my $child;
foreach $child ($dom->contents()) {
if ($child->{tag} eq '#PCDATA') {
my $str = $child->{val};
$str =~ s|(\s+)|</span>$1<span class="pre">|g;
$str =~ s/( +) /(" " x length($1)) . " "/ge;
$child->{val} = qq(<span class="pre">$str</span>);
}
elsif ($child->{tag} eq 'literal') {
$child->{_html}{txt} = $child->{lit};
}
else {
PreprocessLiteral($child);
}
}
}
}
sub (?:doctest|literal)_block = { # PREPROCESS
my ($dom, $str) = @_;
# Go through the children recursively
my $s = TraverseLiteral($dom);
# Get rid of my children
$dom->replace();
return $s;
sub TraverseLiteral {
my ($dom) = @_;
my $str;
my $child;
foreach $child ($dom->contents()) {
$str .= EncodeHTML($child->{text});
}
return $str;
}
}
sub list_item = { # PREPROCESS
my ($dom, $str) = @_;
# Compute whether we're simple or not
my $content = $dom->{content};
my @children = Paras($dom);
pop @children if @children && $children[0]{tag} eq 'paragraph' &&
$children[-1]{tag} =~ /_list$/ && $children[-1]{_html}{simple};
$dom->{_html}{simple} = (@children < 2);
return Default($dom, $str);
}
sub definition|field_body|description|entry = { # PREPROCESS
my ($dom, $str) = @_;
my @paras = Paras($dom);
if (@paras > 1) {
push @{$paras[0]{attr}{classes}}, 'first';
push @{$paras[-1]{attr}{classes}}, 'last';
}
return Default($dom, $str);
}
sub (?:bullet|enumerated)_list = { # PREPROCESS
my ($dom, $str) = @_;
my $parent = $dom->parent();
# I'm simple if all my list_item children are simple.
$dom->{_html}{simple} = 1;
my $li;
foreach $li ($dom->contents()) {
if (! $li->{_html}{simple}) {
$dom->{_html}{simple} = 0;
last;
}
}
# IF I'm not simple, neither are my list_item children
if (! $dom->{_html}{simple}) {
foreach $li ($dom->contents()) {
$li->{_html}{simple} = 0;
push @{$li->{content}[0]{attr}{classes}},'first';
}
}
return Default($dom, $str);
}
sub attention|caution|danger|error|hint|important|note|tip|warning = { # PREPROCESS
my ($dom, $str) = @_;
# Need to turn our title into a paragraph
use vars qw(%ADM_TITLES);
BEGIN {
%ADM_TITLES = ('Danger'=>'!DANGER!', 'Caution'=>'Caution!',
'Attention'=>'Attention!');
}
my $tag = ucfirst $dom->{tag};
my $label = $ADM_TITLES{$tag} || $tag;
my $para = $DOM->new('paragraph',
classes=>[qw(first admonition-title)]);
$para->append($DOM->newPCDATA($label));
$dom->prepend($para);
push @{$dom->{content}[-1]{attr}{classes}}, 'last';
return;
}
sub admonition = { # PREPROCESS
my ($dom, $str) = @_;
push @{$dom->{attr}{classes}}, 'admonition';
my @paras = Paras($dom);
# Need to turn our title into a paragraph and myself into a div
my $para = $DOM->new('paragraph',
classes=>[qw(first admonition-title)]);
$para->append($dom->{content}[0]->contents());
$dom->splice(0, 1, $para);
push @{$paras[-1]{attr}{classes}}, 'last';
$dom->{tag} = 'div';
}
sub footnote|citation = { # PREPROCESS
my ($dom, $str) = @_;
# Get the label out of our first child's child
# Devel::Cover branch 0 1 First child is always label
if ($dom->{content}[0]{tag} eq 'label') {
my $label = $dom->{content}[0]{_html}{str};
chomp $label;
$dom->{_html}{label} = $label;
# Delete the label that is our first child
$dom->splice(0, 1);
}
# Label the first/last paragraph if needed
my @paragraphs = Paras($dom);
push @{$paragraphs[0]{attr}{classes}}, 'first'
if @paragraphs > 1;
push @{$paragraphs[-1]{attr}{classes}}, 'last'
if @paragraphs > 1;
}
sub footnote_reference = { # PREPROCESS
my ($dom, $str) = @_;
# Need to trim a preceding space if using superscript
if ($footnote_references eq 'superscript') {
my $parent = $dom->parent();
my $index = $parent->index($dom);
$parent->{content}[$index-1]{val} =~ s/ +$//
if $index > 0 &&
$parent->{content}[$index-1]{tag} eq '#PCDATA';
}
}
sub definition_list_item = { # PREPROCESS
my ($dom, $str) = @_;
# Need to restructure the classifiers under the term
my @classifiers = grep($_->{tag} eq 'classifier', $dom->contents());
if (@classifiers) {
$dom->splice(1, 0+@classifiers);
$dom->{content}[0]->append(@classifiers);
}
return;
}
sub table = { # PREPROCESS
my ($dom, $str) = @_;
# Turn a title into a caption
$dom->{content}[0]{tag} = 'caption'
if $dom->{content}[0]{tag} eq 'title';
}
sub colspec = { # PREPROCESS
my ($dom, $str) = @_;
# Add the "stub" class to all the entries of my column if I'm stub
if ($dom->{attr}{stub}) {
my $parent = $dom->parent();
my $indx = $parent->index($dom);
foreach my $cont ($parent->contents()) {
next if $cont->{tag} eq 'colspec';
foreach my $row ($cont->contents()) {
push @{$row->{content}[$indx]{attr}{classes}}, 'stub';
}
}
}
return;
}
sub thead = { # PREPROCESS
my ($dom, $str) = @_;
# Add the "head" class to each entry of each row
foreach my $row ($dom->contents()) {
foreach my $entry ($row->contents()) {
unshift @{$entry->{attr}{classes}}, 'head';
}
}
return;
}
sub image = { # PREPROCESS
my ($dom, $str, $writer) = @_;
# Insert a <div> object in the DOM above me if my parent takes
# body elements.
my $ancest = $writer->Ancestors;
my $parent = $ancest->[-1];
# my $parent = $dom->parent();
return unless $parent->takes_body_elts;
my $indx = $parent->index($dom);
my @classes = ('image');
# ??? It either goes directly above me, or if I am
# the only child of a reference, above the reference. ???
push @classes, @{$dom->{attr}{classes}} if $dom->{attr}{classes};
if ($parent->{tag} eq 'reference' && $parent->num_contents() == 1) {
my $pparent = $parent->parent();
$indx = $pparent->index($parent);
$parent = $pparent;
push @classes, 'image-reference';
}
my $div = $DOM->new('div', classes=>\@classes);
$div->append($parent->{content}[$indx]);
$parent->splice($indx, 1, $div);
}
sub generated = { # PREPROCESS
my ($dom, $str) = @_;
return $str;
}
sub sidebar = { # PREPROCESS
my ($dom, $str) = @_;
my @paras = Paras($dom);
# Turn any title or subtitle into paragraphs
foreach my $child ($dom->contents()) {
if ($child->{tag} eq 'title') {
$child->{tag} = 'paragraph';
push @{$child->{attr}{classes}}, qw(first sidebar-title);
}
elsif ($child->{tag} eq 'subtitle') {
$child->{tag} = 'paragraph';
push @{$child->{attr}{classes}}, 'sidebar-subtitle';
}
else {
last;
}
}
push @{$paras[-1]{attr}{classes}}, 'last';
# Turn myself into a div
$dom->{tag} = 'div';
push @{$dom->{attr}{classes}}, 'sidebar';
return;
}
sub rubric = { # PREPROCESS
my ($dom, $str) = @_;
# Turn myself into a paragraph
$dom->{tag} = 'paragraph';
$dom->{attr}{classes} = [ 'rubric' ];
return;
}
sub compound = { # PREPROCESS
my ($dom, $str) = @_;
my @paras = Paras($dom);
if (@paras > 1) {
foreach (my $i=0; $i < @paras; $i++) {
my $c = $i == 0 ? 'compound-first' :
$i == $#paras ? 'compound-last' : 'compound-middle';
unshift @{$paras[$i]{attr}{classes}}, $c;
}
}
# Turn myself into a div
$dom->{tag} = 'div';
push @{$dom->{attr}{classes}}, 'compound';
return;
}
sub mathml = { # PREPROCESS
my ($dom, $str) = @_;
$DOCTYPE = << "EOS" if $dom->{attr}{mathml};
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1 plus MathML 2.0//EN"
"http://www.w3.org/TR/MathML2/dtd/xhtml-math11-f.dtd" [
<!ENTITY mathml "http://www.w3.org/1998/Math/MathML">
]>
EOS
;
return $dom->{attr}{mathml} ? $dom->{attr}{mathml}->text : $str;
}
sub .* = { # PREPROCESS
my ($dom, $str) = @_;
$USED_DEFAULT{$dom->{tag}} = 1;
return Default($dom, $str);
}
}
# This phase produces the final output
phase PROCESS {
sub paragraph = { # PROCESS
my ($dom, $str) = @_;
my $parent = $dom->parent();
my $p_tag = $parent->{tag};
my $index = $parent->index($dom);
my @paras = Paras($parent);
chomp $str;
return "$str"
if (! $dom->{attr}{classes} &&
(($p_tag eq 'list_item' && $parent->{_html}{simple}) ||
(@paras == 1 && $p_tag !~ /list_item|block_quote|topic/)));
$dom->{_html}{attr}{id} = shift @{$dom->{attr}{ids}}
if $dom->{attr}{ids};
my @ids = @{$dom->{attr}{ids}} if $dom->{attr}{ids};
my $spans = join '', map(qq(<$target_tag id="$_"></$target_tag>),
@ids);
my $attr = GetAttr($dom);
return "$spans<p$attr>$str</p>\n";
}
sub \#PCDATA = { # PROCESS
my ($dom, $str) = @_;
return defined $dom->{val} ? $dom->{val} :
EncodeHTML($dom->{text});
}
sub (?:doctest|literal)_block = { # PROCESS
my ($dom, $str) = @_;
my @class = $dom->{attr}{classes} ? @{$dom->{attr}{classes}} : ();
my $class = $dom->{tag};
$class =~ s/_/-/;
push(@class, $class);
my $attr = qq( class=") . join(' ',@class) . qq(");
return qq(<pre$attr>$dom->{val}</pre>\n);
}
sub attention|caution|danger|error|hint|important|note|tip|warning = { # PROCESS
my ($dom, $str) = @_;
my $tag = $dom->{tag};
substr($tag, 0, 1) =~ tr/[a-z]/[A-Z]/;
return qq(<div class="$dom->{tag}">\n$str</div>\n);
}
# These just need to return their string
sub definition_list_item = { # PROCESS
my ($dom, $str) = @_;
return $str;
}
sub title = { # PROCESS
my ($dom, $str) = @_;
my $parent = $dom->parent();
my $p_tag = $parent->{tag} || '';
my $tag;
my $tag_attr = '';
my %a_attr;
# Figure out how deeply I'm nested
my $nesting = $dom->{_html}{nesting};
if ($p_tag =~ /^(topic|sidebar)$/) {
$a_attr{name} = $parent->{attr}{ids}[0]
if $parent->{attr}{classes} &&
$parent->{attr}{classes}[0] eq 'contents';
$tag = "p";
$dom->{tag} = 'paragraph';
$tag_attr = qq( class="$p_tag-title first");
}
elsif ($parent->{attr}{classes}[0] || '' eq 'system-messages') {
$tag_attr = qq( class="title")
if $p_tag eq 'section' &&
grep /^title$/, @{$parent->{attr}{classes}};
$tag = "h$nesting";
}
else {
$a_attr{class} = "toc-backref" if $HAS_CONTENTS;
$a_attr{href} = "#$dom->{attr}{refid}"
if defined $dom->{attr}{refid};
$a_attr{name} = $parent->{attr}{ids}[0];
$tag = "h$nesting";
}
my $a_attr = MakeAttrList(\%a_attr);
chomp $str;
$str = "<a$a_attr>$str</a>" unless $tag eq 'p' && $a_attr eq '';
return qq(<$tag$tag_attr>$str</$tag>\n);
}
sub (?:bullet|enumerated|definition)_list = { # PROCESS
my ($dom, $str) = @_;
# Figure out if I'm the least nested list
use vars qw(%LIST_TAGS);
BEGIN { %LIST_TAGS = ('bullet_list'=>'ul', 'enumerated_list'=>'ol',
'definition_list'=>'dl'); }
my $tag = $LIST_TAGS{$dom->{tag}};
my $attr = $dom->{attr};
$dom->{attr}{classes} = [] if !$dom->{attr}{classes};
my $class = $dom->{attr}{classes};
push @$class, $attr->{enumtype} if $tag eq 'ol';
push @$class, 'docutils' if $tag eq 'dl';
push @$class, 'simple' if $dom->{_html}{simple};
$dom->{_html}{attr}{start} = $attr->{start} if defined $attr->{start};
my $attrlist = GetAttr($dom);
return (qq(<$tag$attrlist>\n$str</$tag>\n));
}
sub list_item = { # PROCESS
my ($dom, $str) = @_;
return qq(<li>$str</li>\n);
}
sub section = { # PROCESS
my ($dom, $str) = @_;
my $attr = $dom->{attr};
my $hattr = $dom->{_html}{attr} = {};
$hattr->{id} = $attr->{ids}[0] if $attr->{ids};
push @{$attr->{classes}}, 'section';
my @ids = @{$attr->{ids}} if $attr->{ids};
shift @ids;
my $spans = join '', map(qq(<$target_tag id="$_"></$target_tag>),
@ids);
my $attrlist = GetAttr($dom);
return qq($spans<div$attrlist>\n$str</div>\n);
}
# All of these items need to chomp a preceding #PCDATA
sub emphasis|strong|subscript|superscript = { # PROCESS
my ($dom, $str) = @_;
use vars qw(%TAG_TRANSLATE);
BEGIN {
%TAG_TRANSLATE = qw(emphasis em subscript sub superscript sup);
}
$dom->{tag} = defined $TAG_TRANSLATE{$dom->{tag}} ?
$TAG_TRANSLATE{$dom->{tag}} : $dom->{tag};
chomp $str;
return Default($dom, $str);
}
sub target = { # PROCESS
my ($dom, $str) = @_;
chomp $str;
my $id = $dom->{attr}{ids} ? $dom->{attr}{ids}[0] : '';
my $class = $str ne '' ? qq( class="target") : '';
return (! defined $dom->{attr}{refuri} &&
! defined $dom->{attr}{refid} &&
defined $dom->{attr}{ids}) || $str ne '' ?
qq(<$target_tag$class id="$id">$str</$target_tag>) :
"";
}
sub problematic = { # PROCESS
my ($dom, $str) = @_;
my $attr = $dom->{attr};
return qq(<a href="#$attr->{refid}" name="$attr->{ids}[0]"><span class="problematic" id="$attr->{ids}[0]">$str</span></a>);
}
sub footnote_reference = { # PROCESS
my ($dom, $str) = @_;
my $parent = $dom->parent();
my %attr;
$attr{class} = "footnote-reference";
my $ref = $attr{href} = "#$dom->{attr}{refid}" if $dom->{attr}{refid};
$attr{name} = $attr{id} = $dom->{attr}{ids}[0];
my $target = &$TARGET_FRAME($ref);
$attr{target} = $target if $target ne '';
my $attr = MakeAttrList(\%attr);
chomp $str;
my $index = $parent->index($dom);
my $ref_str = $footnote_references eq 'superscript' ?
"<sup>$str</sup>" : "[$str]";
return qq(<a$attr>$ref_str</a>);
}
sub literal = { # PROCESS
my ($dom, $str) = @_;
return defined $dom->{_html}{txt} ? $dom->{_html}{txt} :
qq(<tt class="docutils literal">$str</tt>);
}
sub term = { # PROCESS
my ($dom, $str) = @_;
chomp $str;
return qq(<dt>$str</dt>\n);
}
sub classifier = { # PROCESS
my ($dom, $str) = @_;
chomp $str;
return qq( <span class="classifier-delimiter">:</span> <span class="classifier">$str</span>);
}
sub definition = { # PROCESS
my ($dom, $str) = @_;
return qq(<dd>$str</dd>\n);
}
sub reference = { # PROCESS
my ($dom, $str) = @_;
chomp $str;
my $ref = defined $dom->{attr}{refuri} ?
$dom->{attr}{refuri} : defined $dom->{attr}{refid} ?
"#$dom->{attr}{refid}" : undef;
my @class = $dom->{attr}{classes} ?
@{$dom->{attr}{classes}} : ();
push(@class, $dom->{tag});
my $class = join(' ',@class);
my %attr = ('class'=>"$class");
if ($cloak_email_addresses && $ref =~ /^mailto:/) {
# Put back any &whatever; codes
$ref =~ s/&\#(\d+);/chr($1)/ge;
$str =~ s/&\#(\d+);/chr($1)/ge;
$ref =~ /^mailto:(.*)/;
$ref = 'mailto:' . join('', map(sprintf('%%%02X', ord($_)),
split(//, $1)));
$str =~ s!([@\.])!<span>\&\#${\ord($1)};</span>!g;
}
$attr{href} = $ref if defined $ref;
$attr{id} = $dom->{attr}{ids}[0] if $dom->{attr}{ids};
$attr{name} = $dom->{attr}{ids}[0] if $dom->{attr}{ids};
my $target = defined $ref ? &$TARGET_FRAME($ref) : '';
$attr{target} = $target if $target ne '';
my $attr = MakeAttrList(\%attr);
my $s = "<a$attr>$str</a>";
$dom->{_html}{str} = $str;
return $s;
}
sub footnote|citation = { # PROCESS
my ($dom, $str) = @_;
my (@list1, @list2);
my @class = $dom->{attr}{classes} ?
@{$dom->{attr}{classes}} : ();
push @class, 'docutils';
push @class, $dom->{tag};
my $class = qq(class=") . join(' ',@class) . qq(");
push(@list1, qq(<table $class frame="void" id="$dom->{attr}{ids}[0]" rules="none">\n));
unshift(@list2, qq(</table>\n));
push(@list1, qq(<colgroup><col class="label" /><col /></colgroup>\n));
push(@list1, qq(<tbody valign="top">\n));
unshift(@list2, qq(</tbody>\n));
# Devel::Cover branch 0 1 html/label is always defined
my $label = defined $dom->{_html}{label} ? $dom->{_html}{label} :
$dom->{attr}{name};
my $backlinks;
my @backrefs = @{$dom->{attr}{backrefs}} if $dom->{attr}{backrefs};
if ($footnote_backlinks && @backrefs) {
if (@backrefs > 1) {
$backlinks = '<em>(' . join(', ',map(qq(<a class="fn-backref" href="#$backrefs[$_-1]">$_</a>), 1 .. @backrefs)) . ')</em> ';
push(@list1, qq(<tr><td class="label"><a name="$dom->{attr}{ids}[0]">[$label]</a></td><td>$backlinks$str</td></tr>\n));
}
else {
push(@list1, qq(<tr><td class="label"><a class="fn-backref" href="#$dom->{attr}{backrefs}[0]" name="$dom->{attr}{ids}[0]">[$label]</a></td><td>$str</td></tr>\n));
}
}
else {
push(@list1, qq(<tr><td class="label"><a name="$dom->{attr}{ids}[0]">[$label]</a></td><td>$str</td></tr>\n));
}
return join '', @list1, @list2;
}
sub block_quote = { # PROCESS
my ($dom, $str) = @_;
my $attr = GetAttr($dom);
return qq(<blockquote$attr>\n$str</blockquote>\n);
}
sub attribution = { # PROCESS
my ($dom, $str) = @_;
return '' if $attribution eq 'none';
chomp $str;
my $att = $attribution eq 'dash' ? "—$str" : "($str)";
return qq(<p class="attribution">$att</p>\n);
}
sub comment = { # PROCESS
my ($dom, $str) = @_;
my $text = join('',map($_->{tag} eq '#PCDATA' ? $_->{text} : "",
$dom->contents()));
chomp $text;
$text =~ s/--/- -/g;
return qq(<!-- $text -->\n);
}
sub topic = { # PROCESS
my ($dom, $str) = @_;
my $hattr = $dom->{_html}{attr} = {};
my $class = $dom->{attr}{classes} ? $dom->{attr}{classes}[0] : '';
if ($class eq 'contents') {
$HAS_CONTENTS = 1;
$hattr->{id} = $dom->{attr}{ids}[0];
}
my %attr;
push @{$dom->{attr}{classes}}, 'topic';
my $attrlist = GetAttr($dom);
return qq(<div$attrlist>\n$str</div>\n);
}
sub field_list = { # PROCESS
my ($dom, $str) = @_;
my (@list1, @list2);
push(@list1,
qq(<table class="docutils field-list" frame="void" rules="none">\n),
qq(<col class="field-name" />\n),
qq(<col class="field-body" />\n),
qq(<tbody valign="top">\n)
);
unshift(@list2, qq(</table>\n));
unshift(@list2, qq(</tbody>\n));
return join '', @list1, $str, @list2;
}
sub field_(?:name|argument|body) = { # PROCESS
my ($dom, $str) = @_;
chomp $str;
return $str;
}
sub field = { # PROCESS
my ($dom, $str) = @_;
my %fields = map(($_->{tag}, $_->{val}), $dom->contents());
my @str;
my $fieldname = $fields{field_name};
# Back-convert HTML codes to figure out how long fieldargs is
(my $fieldchars = $fieldname) =~ s/&.*;/ /g;
my $colspan = length($fieldchars) > $field_limit ?
qq( colspan="2") : '';
my $tr = $colspan ? "</tr>\n" : '';
my $cr = $fields{field_body} =~ m|</p>$| ? "\n" : '';
push(@str,
qq(<tr class="field"><th class="field-name"$colspan>$fieldname:</th>$tr));
push(@str, $colspan ?
qq(<tr><td> </td><td class="field-body">$fields{field_body}$cr</td>\n)
: qq(<td class="field-body">$fields{field_body}$cr</td>\n)
);
push(@str, qq(</tr>\n));
return join '',@str;
}
sub transition = { # PROCESS
return qq(<hr class="docutils" />\n);
}
sub option_list = { # PROCESS
my ($dom, $str) = @_;
return << "EOS" ;
<table class="docutils option-list" frame="void" rules="none">
<col class="option" />
<col class="description" />
<tbody valign="top">
$str</tbody>
</table>
EOS
}
sub option_list_item = { # PROCESS
my ($dom, $str) = @_;
return qq(<tr>$str</tr>\n);
}
sub option_group = { # PROCESS
my ($dom, $str) = @_;
my $parent = $dom->parent();
my $val = join(', ', map($_->{val}, $dom->contents()));
# Figure out what the raw text is
my $raw = $val;
$raw =~ s/<[^>]*>//g;
my $cspan = '';
if (length($raw) > $option_limit) {
$cspan = qq( colspan="2");
$parent->{_html}{colspan} = 2;
}
return qq(<td class="option-group"$cspan>\n<kbd>$val</kbd></td>\n);
}
sub option_string = { # PROCESS
my ($dom, $str) = @_;
return qq($str);
}
sub option = { # PROCESS
my ($dom, $str) = @_;
return qq(<span class="option">$str</span>);
}
sub option_argument = { # PROCESS
my ($dom, $str) = @_;
return qq($dom->{attr}{delimiter}<var>$str</var>);
}
sub description = { # PROCESS
my ($dom, $str) = @_;
my $parent = $dom->parent();
my $append = ($parent->{_html}{colspan} || 0) == 2 ?
qq(</tr>\n<tr><td> </td>) : '';
return qq($append<td>$str</td>);
}
sub table = { # PROCESS
my ($dom, $str) = @_;
my $tattr = $dom->{table_attr} || '';
%{$dom->{_html}{attr}} = ($tattr =~ /(\w+)(?:=(\S+))?/g,
$tattr =~ /(\w+)="(.*?)"/g);
if ($dom->{_html}{attr}{class}) {
push @{$dom->{attr}{classes}}, $dom->{_html}{attr}{class};
delete $dom->{_html}{attr}{class};
}
my $attr = GetAttr($dom);
return qq(<table$attr>\n$str</table>\n);
}
sub tgroup = { # PROCESS
my ($dom, $str) = @_;
my $cols = $dom->{attr}{cols};
my $rest = join('', map($dom->{content}[$_]{val},
$cols .. ($dom->num_contents()-1)));
return $rest unless $colspecs;
my @colwidths = map($dom->{content}[$_]{attr}{colwidth},
0 .. $cols-1);
my $total = 0;
grep($total += $_, @colwidths);
my $colspecs = join('',map(sprintf(qq(<col width="%s%%" />\n),
int(100*$_/$total+.5)),
@colwidths));
my $colgroup = "<colgroup>\n$colspecs</colgroup>\n";
return qq($colgroup$rest);
}
sub thead = { # PROCESS
my ($dom, $str) = @_;
$str =~ s|(</?t)d|${1}h|g;
return qq(<thead valign="bottom">\n$str</thead>\n);
}
sub tbody = { # PROCESS
my ($dom, $str) = @_;
return qq(<tbody valign="top">\n$str</tbody>\n);
}
sub row = { # PROCESS
my ($dom, $str) = @_;
my $attr = defined $dom->{row_attr} && $dom->{row_attr} ne '' ?
" $dom->{row_attr}" : '';
return qq(<tr$attr>$str</tr>\n);
}
sub entry = { # PROCESS
my ($dom, $str) = @_;
my $attr = $dom->{attr};
my $eattr = $dom->{entry_attr} || '';
# Devel::Cover branch 0 1 there are no pass-thru attributes
%{$dom->{_html}{attr}} =
(map($_ eq 'morerows' ? ('rowspan'=>$attr->{$_}+1) :
$_ eq 'morecols' ? ('colspan'=>$attr->{$_}+1) :
$_ eq 'classes' ||
$_ eq 'align' && $attr->{$_} eq 'left'? () :
($_=>$attr->{$_}), keys %$attr),
$eattr =~ /(\w+)(?:=(\S+))?/g,
$eattr =~ /(\w+)="(.*?)"/g);
my $attrlist = GetAttr($dom);
$str = ' ' if $str eq '';
my $tag = $attr->{classes} && grep($_ eq 'stub', @{$attr->{classes}}) ?
"th" : "td";
return qq(<$tag$attrlist>$str</$tag>\n);
}
sub citation_reference = { # PROCESS
my ($dom, $str) = @_;
my $hattr = $dom->{_html}{attr} = {};
push @{$dom->{attr}{classes}}, 'citation-reference';
my $ref = $hattr->{href} = "#$dom->{attr}{refid}";
$hattr->{name} = $hattr->{id} = $dom->{attr}{ids}[0];
my $target = &$TARGET_FRAME($ref);
$hattr->{target} = $target if $target ne '';
my $attr = GetAttr($dom);
return qq(<a$attr>[$str]</a>);
}
sub image = { # PROCESS
my ($dom, $str) = @_;
my $attr = $dom->{attr};
my $alt = defined $attr->{alt} ? $attr->{alt} : $attr->{uri};
my $hattr = $dom->{_html}{attr} = {};
@$hattr{qw(alt src)} = ($alt, $attr->{uri});
if ($IMAGE_EXT_RE) {
$hattr->{src} =~ s/($IMAGE_EXT_RE)$/$IMAGE_EXTS{$1}/o;
}
my @attr_out = qw(height width align usemap);
foreach (@attr_out) {
$hattr->{$_} = $attr->{$_} if defined $attr->{$_};
}
# $hattr->{refid} = $dom->{attr}{ids} if $dom->{attr}{ids};
my $attrlist = GetAttr($dom);
my $img = qq(<img$attrlist />);
return $img;
}
sub figure = { # PROCESS
my ($dom, $str) = @_;
# Copy the non-classes attributes to {_html}{attr}
%{$dom->{_html}{attr}} = map($_ ne 'classes' ? ($_, $dom->{attr}{$_}) :
(), keys %{$dom->{attr}});
push @{$dom->{attr}{classes}}, 'figure';
my $attr = GetAttr($dom);
return qq(<div$attr>\n$str</div>\n);
}
sub caption = { # PROCESS
my ($dom, $str) = @_;
chomp $str;
my $parent = $dom->parent();
return $parent->{tag} eq 'table' ? qq(<caption>$str</caption>\n) :
qq(<p class="caption">$str</p>\n);
}
sub legend = { # PROCESS
my ($dom, $str) = @_;
return qq(<div class="legend">\n$str</div>\n);
}
sub line_block = { # PROCESS
my ($dom, $str) = @_;
$dom->{attr}{classes} = [ 'line-block' ] unless $dom->{attr}{classes};
my $attr = GetAttr($dom);
return qq(<div$attr>\n$str</div>\n);
}
sub line = { # PROCESS
my ($dom, $str) = @_;
chomp $str;
$str = "<br />" if $str eq '';
return qq(<div class="line">$str</div>\n);;
}
sub parsed_literal = { # PROCESS
my ($dom, $str) = @_;
return qq(<pre class="parsed-literal">$str</pre>\n);
}
sub system_message = { # PROCESS
my ($dom, $str) = @_;
my $parent = $dom->parent();
my $attr = $dom->{attr};
my $backlink = $attr->{backrefs} ?
'; <em>backrefs ' .
join(' ',map(qq(<a href="#$_">$_</a>), @{$attr->{backrefs}})) .
'</em>' : '';
my $name = $attr->{ids} ? qq( name="$attr->{ids}[0]") : '';
my $line = $attr->{line} ? qq(, line $attr->{line}) : '';
my $id = $attr->{ids} ? qq( id="$attr->{ids}[0]") : '';
return << "EOS"
<div class="system-message"$id>
<p class="system-message-title">System Message: <a$name>$attr->{type}/$attr->{level}</a> (<tt class="docutils">$attr->{source}</tt>$line)$backlink</p>
$str</div>
EOS
if ($parent->{attr}{classes} && @{$parent->{attr}{classes}} &&
$parent->{attr}{classes}[0] eq 'system-messages');
return;
}
sub raw = { # PROCESS
my ($dom) = @_;
return unless $dom->{attr}{format} =~ /\bhtml\b/;
my $s = $dom->{content}[0]{text};
chomp $s;
if ($dom->{attr}{head}) {
push @HEAD, "$s\n";
return;
}
return $s unless $dom->{attr}{classes};
my $parent = $dom->parent();
my $tag = $parent->{tag} =~ /section|document/ ? 'div' : 'span';
my $attr = GetAttr($dom);
return qq(<$tag$attr>$s</$tag>);
}
sub subtitle|label|decoration|colspec|substitution_(?:definition|reference) = { # PROCESS
return;
}
sub document = { # PROCESS
my ($dom, $str, $writer) = @_;
my $doc = [[], []];
# Handle the prolog
my $enc = $writer->{opt}{e} || 'utf-8';
push @{$doc->[0]}, qq(<?xml version="1.0" encoding="$enc" ?>\n)
unless $html_prolog;
push @{$doc->[0]}, $DOCTYPE;
push (@{$doc->[0]}, qq(<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">\n));
unshift (@{$doc->[1]}, qq(</html>\n));
# Handle the header
my $head = [["<head>\n"], ["</head>\n"]];
push (@{$doc->[0]}, $head);
push (@{$head->[0]},
qq(<meta http-equiv="Content-Type" content="text/html; charset=$enc" />\n));
push (@{$head->[0]},
qq(<meta name="generator" content="$dom->{TOOL_ID}" />\n))
unless defined $writer->{opt}{D}{generator} &&
$writer->{opt}{D}{generator} eq 0;
my $title = $dom->num_contents() &&
$dom->{content}[0]{tag} eq 'title' ?
$dom->{content}[0]{_html}{str} : $dom->{attr}{title} || '';
chomp $title;
my $subtitle = $dom->num_contents() > 1 &&
$dom->{content}[1]{tag} eq 'subtitle' ?
$dom->{content}[1]{_html}{str} : '';
chomp $subtitle;
push (@{$head->[0]}, "<title>$title</title>\n") if $title ne '';
push (@{$head->[0]},
map(ref($_) ? qq(<meta name="$_->[0]" content="$_->[1]" />\n) :
$_, @HEAD_INFO));
my @embeds;
if ($stylesheet =~ /^none$/i) {
# Find the default stylesheet
my $default = "Text/Restructured/default.css";
my ($dir) = grep -f "$_/$default", @INC;
push @embeds, "$dir/$default";
$stylesheet = 0;
}
elsif ($stylesheet !~ /^http:/ && $embed_stylesheet) {
push @embeds, $stylesheet =~ m!^file:(?://)?(.*)! ? $1 :
$stylesheet;
$stylesheet = 0;
}
if ($stylesheet) {
push @{$head->[0]}, qq(<link rel="stylesheet" href="$stylesheet" type="text/css" />\n);
}
push @embeds, $stylesheet2 if $stylesheet2;
foreach my $embed (@embeds) {
open SS, $embed or die "Cannot open stylesheet $embed";
my $ss_text = join '', <SS>;
push(@{$head->[0]},
sprintf(qq(<style type="text/css">\n%s</style>\n),
$ss_text));
}
push @{$head->[0]}, @HEAD if @HEAD;
# Handle the body.
my $battr = $body_attr ? " $body_attr" : '';
my $body = [["<body$battr>\n"], ["</body>\n"]];
unshift @{$body->[1]}, $FOOTER if defined $FOOTER;
push @{$doc->[0]}, $body;
push @{$body->[0]}, $HEADER if defined $HEADER;
push @{$body->[0]}, map(qq(<span id="$_"></span>),
@{$dom->{attr}{ids}}
[1 .. $#{$dom->{attr}{ids}}])
if $dom->{attr}{ids} && @{$dom->{attr}{ids}} > 1;
push (@{$body->[0]},
qq(<div class="document") .
($dom->{attr}{ids} ? qq( id="$dom->{attr}{ids}[0]") : "")
. qq(>\n));
unshift (@{$body->[1]}, qq(</div>\n));
push (@{$body->[0]}, qq(<h1 class="title">$title</h1>\n))
if $title ne '' && ! $writer->{opt}{D}{keep_title_section};
my $id = $dom->num_contents() > 1 &&
$dom->{content}[1]{attr}{ids} ?
qq( id="$dom->{content}[1]{attr}{ids}[0]") : '';
if ($subtitle ne '') {
my $stdom = $dom->{content}[1];
push @{$body->[0]}, map(qq(<span id="$_"></span>),
@{$stdom->{attr}{ids}}
[1 .. $#{$stdom->{attr}{ids}}])
if @{$stdom->{attr}{ids}} > 1;
push (@{$body->[0]}, qq(<h2 class="subtitle"$id>$subtitle</h2>\n))
}
# Next go through all the contents
my $content;
foreach $content ($dom->contents()) {
next if $content->{tag} =~ /title$/;
push (@{$body->[0]}, $content->{val});
}
my @list = Flatten($doc);
return join '',@list;
# This subroutine takes an array of items which may
# contain array references and flattens them into the
# a new array.
sub Flatten {
my @answer;
foreach (@_) {
next unless defined $_;
if (ref($_) eq 'ARRAY') {
push(@answer, Flatten(@$_));
}
else {
push(@answer, $_);
}
}
return @answer;
}
}
sub docinfo = { # PROCESS
my ($dom, $str) = @_;
$str =~ s/field-name/docinfo-name/g;
return << "EOS" ;
<table class="docinfo" frame="void" rules="none">
<col class="docinfo-name" />
<col class="docinfo-content" />
<tbody valign="top">
$str</tbody>
</table>
EOS
}
sub address = { # PROCESS
my ($dom, $str) = @_;
return << "EOS" ;
<tr><th class="docinfo-name">Address:</th>
<td><pre class="address">
$str</pre>
</td></tr>
EOS
}
sub author|contact|organization|date|status|revision|version|copyright = { # PROCESS
my ($dom, $str) = @_;
my $label = $dom->{tag};
substr($label,0,1) =~ tr/[a-z]/[A-Z]/;
chomp $str;
return qq(<tr><th class="docinfo-name">$label:</th>\n<td>$str</td></tr>\n);
}
sub header = { # PROCESS
my ($dom, $str) = @_;
$HEADER =
qq(<div class="header">\n$str\n<hr class="header"/>\n</div>\n);
return;
}
sub footer = { # PROCESS
my ($dom, $str) = @_;
$FOOTER =
qq(<div class="footer">\n<hr class="footer" />\n$str\n</div>\n);
return;
}
sub div = { # PROCESS
my ($dom, $str) = @_;
my $nl = $dom->num_contents() > 1 ? "\n" : '';
return qq(<div class="@{$dom->{attr}{classes}}">$nl$str</div>\n);
}
sub title_reference = { # PROCESS
my ($dom, $str) = @_;
return qq(<cite>$str</cite>);
}
sub inline = { # PROCESS
my ($dom, $str) = @_;
my $tag = 'span';
my $attr = GetAttr($dom);
return qq(<$tag$attr>$str</$tag>);
}
sub .* = { # PROCESS
my ($dom, $str) = @_;
if ($USED_DEFAULT{$dom->{tag}}) {
print STDERR
"Warning: Used default handler for type $dom->{tag}\n";
$USED_DEFAULT{$dom->{tag}} = 0;
}
return $dom->{val};
}
}