Permalink
Browse files

import Pod::Simple 3.01 from CPAN

git-cpan-module: Pod::Simple
git-cpan-version: 3.01
git-cpan-authorid: SBURKE
  • Loading branch information...
1 parent 011585b commit 0cd525547cfedeeece1e5806008e2af1ac534f32 Sean M. Burke committed with schwern May 24, 2004
Showing with 4,385 additions and 184 deletions.
  1. +23 −1 ChangeLog
  2. +38 −0 MANIFEST
  3. +1 −0 MANIFEST.SKIP
  4. +13 −2 META.yml
  5. +17 −12 Makefile.PL
  6. +1 −1 lib/Pod/Simple.pm
  7. +577 −144 lib/Pod/Simple/HTML.pm
  8. +1,342 −0 lib/Pod/Simple/HTMLBatch.pm
  9. +104 −0 lib/Pod/Simple/HTMLLegacy.pm
  10. +93 −0 lib/Pod/Simple/Progress.pm
  11. +986 −0 lib/Pod/Simple/Search.pm
  12. +5 −5 lib/Pod/Simple/Subclassing.pod
  13. +23 −3 lib/Pod/Simple/XMLOutStream.pm
  14. +37 −9 t/00about.t
  15. +3 −0 t/corpus/greek_iso_8859_7.pod
  16. +8 −7 t/html-para.t
  17. +84 −0 t/htmlbatch_01.t
  18. +10 −0 t/other^test^lib/Sizzlesuzzle.pm
  19. +11 −0 t/other^test^lib/hink^honk/Glunk.pod
  20. +14 −0 t/other^test^lib/hink^honk/Vliff.pm
  21. +1 −0 t/other^test^lib/hink^honk/readme.txt
  22. +7 −0 t/other^test^lib/pod/perlthang.pod
  23. +7 −0 t/other^test^lib/pod/perlzuk.pod
  24. +14 −0 t/other^test^lib/squaa/Vliff.pm
  25. +11 −0 t/other^test^lib/squaa/Wowo.pod
  26. +34 −0 t/search_05sane.t
  27. +68 −0 t/search_10survey_specific.t
  28. +61 −0 t/search_12survey_cwd.t
  29. +70 −0 t/search_20survey_two.t
  30. +98 −0 t/search_22survey_two_shadowing.t
  31. +95 −0 t/search_25_glob_squaa_coloncolon_kleene.t
  32. +78 −0 t/search_26_glob_kleene_k.t
  33. +92 −0 t/search_27_glob_squaa_kleene.t
  34. +68 −0 t/search_28_glob_z_kleene_k.t
  35. +68 −0 t/search_29_glob_z_qmark_k.t
  36. +61 −0 t/search_50survey_inc.t
  37. +10 −0 t/test^lib/Blorm.pm
  38. +4 −0 t/test^lib/Zonk/Fiddle.txt
  39. +43 −0 t/test^lib/Zonk/Pronk.pm
  40. +4 −0 t/test^lib/Zonk/Veng.pm
  41. +11 −0 t/test^lib/hink^honk/Glunk.pod
  42. +14 −0 t/test^lib/hink^honk/Vliff.pm
  43. +1 −0 t/test^lib/hink^honk/readme.txt
  44. +7 −0 t/test^lib/pod/perlfliff.pod
  45. +7 −0 t/test^lib/pod/perlthang.pod
  46. +12 −0 t/test^lib/squaa.pm
  47. +11 −0 t/test^lib/squaa/Glunk.pod
  48. +14 −0 t/test^lib/squaa/Vliff.pm
  49. +10 −0 t/test^lib/zikzik.pod
  50. +14 −0 t/yet^another^test^lib/squaa/Vliff.pm
View
24 ChangeLog
@@ -1,6 +1,28 @@
-# ChangeLog for Pod::Simple dist # Time-stamp: "2004-05-07 15:25:25 ADT"
+# ChangeLog for Pod::Simple dist # Time-stamp: "2004-05-24 02:05:45 ADT"
#---------------------------------------------------------------------------
+2004-05-24 Sean M. Burke <sburke@cpan.org>
+ * Relesae 3.01
+
+ No big changes to the main modules, but there's many changes to
+ the important Pod::Simple::HTML module.
+
+ Also, new modules:
+ Pod::Simple::HTMLBatch
+ Pod::Simple::HTMLLegacy
+ Pod::Simple::Progress
+ Pod::Simple::Search
+ and tests for these (well, most).
+
+ Some prettying up of the Makefile.PL.
+
+ The test 00about.t is a bit more careful and verbose now.
+
+ The docs are still incomplete, esp. for Pod::Simple::HTML and
+ Pod::Simple::HTMLBatch, which I hope to improve quite soon.
+
+
+
2004-05-07 Sean M. Burke <sburke@cpan.org>
* Release 2.06
View
38 MANIFEST
@@ -9,14 +9,18 @@ lib/Pod/Simple/Debug.pm
lib/Pod/Simple/DumpAsText.pm
lib/Pod/Simple/DumpAsXML.pm
lib/Pod/Simple/HTML.pm
+lib/Pod/Simple/HTMLBatch.pm
+lib/Pod/Simple/HTMLLegacy.pm
lib/Pod/Simple/LinkSection.pm
lib/Pod/Simple/Methody.pm
+lib/Pod/Simple/Progress.pm
lib/Pod/Simple/PullParser.pm
lib/Pod/Simple/PullParserEndToken.pm
lib/Pod/Simple/PullParserStartToken.pm
lib/Pod/Simple/PullParserTextToken.pm
lib/Pod/Simple/PullParserToken.pm
lib/Pod/Simple/RTF.pm
+lib/Pod/Simple/Search.pm
lib/Pod/Simple/SimpleTree.pm
lib/Pod/Simple/Subclassing.pod
lib/Pod/Simple/Text.pm
@@ -113,15 +117,48 @@ t/heads.t
t/html-para.t
t/html-styles.t
t/html-title.t
+t/htmlbatch_01.t
t/itemadapt.t
t/items.t
t/itemstar.t
t/linkclass.t
+t/other^test^lib/hink^honk/Glunk.pod
+t/other^test^lib/hink^honk/readme.txt
+t/other^test^lib/hink^honk/Vliff.pm
+t/other^test^lib/pod/perlthang.pod
+t/other^test^lib/pod/perlzuk.pod
+t/other^test^lib/Sizzlesuzzle.pm
+t/other^test^lib/squaa/Vliff.pm
+t/other^test^lib/squaa/Wowo.pod
t/puller.t
t/pulltitle.t
t/render.t
t/sanity_tfh.t
+t/search_05sane.t
+t/search_10survey_specific.t
+t/search_12survey_cwd.t
+t/search_20survey_two.t
+t/search_22survey_two_shadowing.t
+t/search_25_glob_squaa_coloncolon_kleene.t
+t/search_26_glob_kleene_k.t
+t/search_27_glob_squaa_kleene.t
+t/search_28_glob_z_kleene_k.t
+t/search_29_glob_z_qmark_k.t
+t/search_50survey_inc.t
t/stree.t
+t/test^lib/Blorm.pm
+t/test^lib/hink^honk/Glunk.pod
+t/test^lib/hink^honk/readme.txt
+t/test^lib/hink^honk/Vliff.pm
+t/test^lib/pod/perlfliff.pod
+t/test^lib/pod/perlthang.pod
+t/test^lib/squaa.pm
+t/test^lib/squaa/Glunk.pod
+t/test^lib/squaa/Vliff.pm
+t/test^lib/zikzik.pod
+t/test^lib/Zonk/Fiddle.txt
+t/test^lib/Zonk/Pronk.pm
+t/test^lib/Zonk/Veng.pm
t/test_junk1.pod
t/test_junk1_out.txt
t/test_junk2.pod
@@ -135,4 +172,5 @@ t/test_old_perlvar_out.txt
t/verbatim_formatted.t
t/verbatims.t
t/x_nixer.t
+t/yet^another^test^lib/squaa/Vliff.pm
META.yml Module meta-data (added by MakeMaker)
View
1 MANIFEST.SKIP
@@ -1,6 +1,7 @@
^MANIFEST\.bak$
^[-_a-zA-Z0-9]+[0-9]+\.[0-9]+(?:_[0-9]+)?$
\.out$
+delme
Makefile(\.old)?$
\.rej$
CVS
View
15 META.yml
@@ -1,11 +1,22 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Pod-Simple
-version: 2.06
+version: 3.01
version_from: lib/Pod/Simple.pm
installdirs: site
requires:
- Pod::Escapes: 1.03
+ Carp: 0
+ Config: 0
+ constant: 0
+ Cwd: 0
+ File::Basename: 0
+ File::Find: 0
+ File::Spec: 0
+ integer: 0
+ overload: 0
+ Pod::Escapes: 1.04
+ strict: 0
+ Symbol: 0
Text::Wrap: 98.112902
distribution_type: module
View
29 Makefile.PL
@@ -1,6 +1,6 @@
# This -*- perl -*- script writes the Makefile for Pod::Simple
#
-# Time-stamp: "2003-11-01 21:15:13 AST"
+# Time-stamp: "2004-05-24 00:21:20 ADT"
#
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
@@ -11,17 +11,22 @@ require 5;
use strict;
use ExtUtils::MakeMaker;
-WriteMakefile
- (
- NAME => 'Pod::Simple',
- VERSION_FROM => 'lib/Pod/Simple.pm',
- ABSTRACT_FROM => 'lib/Pod/Simple.pod',
- PREREQ_PM => {
- 'Text::Wrap' => '98.112902',
- 'Pod::Escapes' => '1.03',
- },
- # INSTALLDIRS => 'perl',
- );
+WriteMakefile(
+ NAME => 'Pod::Simple',
+ VERSION_FROM => 'lib/Pod/Simple.pm',
+ ABSTRACT_FROM => 'lib/Pod/Simple.pod',
+ # INSTALLDIRS => 'perl',
+ PREREQ_PM => {
+ 'Text::Wrap' => '98.112902',
+ 'Pod::Escapes' => '1.04',
+
+ # And finally, things I don't have any particular version in mind for:
+ map {; $_ => 0 } qw[
+ File::Spec File::Basename Cwd Config Carp overload Symbol strict
+ constant integer File::Find
+ ]
+ },
+);
package MY;
View
2 lib/Pod/Simple.pm
@@ -18,7 +18,7 @@ use vars qw(
);
@ISA = ('Pod::Simple::BlackBox');
-$VERSION = '2.06';
+$VERSION = '3.01';
@Known_formatting_codes = qw(I B C L E F S X Z);
%Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
View
721 lib/Pod/Simple/HTML.pm
@@ -3,18 +3,78 @@ require 5;
package Pod::Simple::HTML;
use strict;
use Pod::Simple::PullParser ();
-use vars qw(@ISA %Tagmap $Computerese $Lame $Linearization_Limit $VERSION);
+use vars qw(
+ @ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION
+ $Perldoc_URL_Prefix $Perldoc_URL_Postfix
+ $Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex
+ $Doctype_decl $Content_decl
+);
@ISA = ('Pod::Simple::PullParser');
-$VERSION = '2.02';
+$VERSION = '3.01';
use UNIVERSAL ();
-sub DEBUG () {0}
+BEGIN {
+ if(defined &DEBUG) { } # no-op
+ elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
+ else { *DEBUG = sub () {0}; }
+}
+
+$Doctype_decl ||= ''; # No. Just No. Don't even ask me for it.
+ # qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+ # "http://www.w3.org/TR/html4/loose.dtd">\n};
+$Content_decl ||=
+ q{<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" >};
+
+$HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION;
$Computerese = " lang='und' xml:lang='und'" unless defined $Computerese;
-$Lame = ' class="pad"' unless defined $Lame;
+$LamePad = '<p class="pad"></p>' unless defined $LamePad;
-$Linearization_Limit = 90 unless defined $Linearization_Limit;
+$Linearization_Limit = 120 unless defined $Linearization_Limit;
# headings/items longer than that won't get an <a name="...">
+$Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?'
+ unless defined $Perldoc_URL_Prefix;
+$Perldoc_URL_Postfix = ''
+ unless defined $Perldoc_URL_Postfix;
+
+$Title_Prefix = '' unless defined $Title_Prefix;
+$Title_Postfix = '' unless defined $Title_Postfix;
+%ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text
+ # 'item-text' stuff in the index doesn't quite work, and may
+ # not be a good idea anyhow.
+
+
+__PACKAGE__->_accessorize(
+ 'perldoc_url_prefix',
+ # In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
+ # to put before the "Foo%3a%3aBar".
+ # (for singleton mode only?)
+ 'perldoc_url_postfix',
+ # what to put after "Foo%3a%3aBar" in the URL. Normally "".
+
+ 'batch_mode', # whether we're in batch mode
+ 'batch_mode_current_level',
+ # When in batch mode, how deep the current module is: 1 for "LWP",
+ # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
+
+ 'title_prefix', 'title_postfix',
+ # What to put before and after the title in the head.
+ # Should already be &-escaped
+
+ 'html_header_before_title',
+ 'html_header_after_title',
+ 'html_footer',
+
+ 'index', # whether to add an index at the top of each page
+ # (actually it's a table-of-contents, but we'll call it an index,
+ # out of apparently longstanding habit)
+
+ 'html_css', # URL of CSS file to point to
+ 'html_javascript', # URL of CSS file to point to
+
+ 'force_title', # should already be &-escaped
+ 'default_title', # should already be &-escaped
+);
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
my @_to_accept;
@@ -77,11 +137,11 @@ my @_to_accept;
] # no point in providing a way to get <q>...</q>, I think
),
- '/item-bullet' => "</li><p$Lame></p>\n",
- '/item-number' => "</li><p$Lame></p>\n",
- '/item-text' => "</a></dt><p$Lame></p>\n",
+ '/item-bullet' => "</li>$LamePad\n",
+ '/item-number' => "</li>$LamePad\n",
+ '/item-text' => "</a></dt>$LamePad\n",
'Para_item' => "\n<dd>",
- '/Para_item' => "</dd><p$Lame></p>\n",
+ '/Para_item' => "</dd>$LamePad\n",
'B' => "<b>", '/B' => "</b>",
'I' => "<i>", '/I' => "</i>",
@@ -103,6 +163,10 @@ sub changes2 {
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub go { exit Pod::Simple::HTML->parse_from_file(@ARGV) }
+ # Just so we can run from the command line. No options.
+ # For that, use perldoc!
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub new {
my $new = shift->SUPER::new(@_);
@@ -112,11 +176,37 @@ sub new {
$new->accept_codes('VerbatimFormatted');
$new->accept_codes(@_to_accept);
DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
-
+
+ $new->perldoc_url_prefix( $Perldoc_URL_Prefix );
+ $new->perldoc_url_postfix( $Perldoc_URL_Postfix );
+ $new->title_prefix( $Title_Prefix );
+ $new->title_postfix( $Title_Postfix );
+
+ $new->html_header_before_title(
+ qq[$Doctype_decl<html><head><title>]
+ );
+ $new->html_header_after_title( join "\n" =>
+ "</title>",
+ $Content_decl,
+ "</head>\n<body class='pod'>",
+ $new->version_tag_comment,
+ "<!-- start doc -->\n",
+ );
+ $new->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] );
+
$new->{'Tagmap'} = {%Tagmap};
return $new;
}
+sub batch_mode_page_object_init {
+ my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
+ DEBUG and print "Initting $self\n for $module\n",
+ " in $infile\n out $outfile\n depth $depth\n";
+ $self->batch_mode(1);
+ $self->batch_mode_current_level($depth);
+ return $self;
+}
+
sub run {
my $self = $_[0];
return $self->do_middle if $self->bare_output;
@@ -126,96 +216,228 @@ sub run {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-sub do_pod_link {
- my($self, $link) = @_;
- my $to = $link->attr('to');
- my $section = $link->attr('section');
- return undef unless( # should never happen
- (defined $to and length $to) or
- (defined $section and length $section)
- );
+sub do_beginning {
+ my $self = $_[0];
- if(defined $to and length $to) {
- $to = $self->resolve_pod_page_link($to, $section);
- return undef unless defined $to and length $to;
- # resolve_pod_page_link returning undef is how it
- # can signal that it gives up on making a link
- # (I pass it the section value, but I don't see a
- # particular reason it'd use it.)
- }
-
- if(defined $section and length($section .= '')) {
- $section =~ tr/ /_/;
- $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65);
- $section = $self->unicode_escape_url($section);
- # Turn char 1234 into "(1234)"
- $section = '_' unless length $section;
- }
-
+ my $title;
+ if(defined $self->force_title) {
+ $title = $self->force_title;
+ DEBUG and print "Forcing title to be $title\n";
+ } else {
+ # Actually try looking for the title in the document:
+ $title = $self->get_short_title();
+ unless($self->content_seen) {
+ DEBUG and print "No content seen in search for title.\n";
+ return;
+ }
+ $self->{'Title'} = $title;
- foreach my $it ($to, $section) {
- if( defined $it ) {
- $it =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg;
- $it =~ s/([^\._abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
- # Yes, stipulate the list without a range, so that this can work right on
- # all charsets that this module happens to run under.
- # Altho, hmm, what about that ord? Presumably that won't work right
- # under non-ASCII charsets. Something should be done about that.
+ if(defined $title and $title =~ m/\S/) {
+ $title = $self->title_prefix . esc($title) . $self->title_postfix;
+ } else {
+ $title = $self->default_title;
+ $title = '' unless defined $title;
+ DEBUG and print "Title defaults to $title\n";
}
}
+
- my $out = $to if defined $to and length $to;
- $out .= "#" . $section if defined $section and length $section;
- return undef unless length $out;
- return $out;
+ my $after = $self->html_header_after_title || '';
+ if($self->html_css) {
+ my $link =
+ $self->html_css =~ m/</
+ ? $self->html_css # It's a big blob of markup, let's drop it in
+ : sprintf( # It's just a URL, so let's wrap it up
+ qq[<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="%s">\n],
+ $self->html_css,
+ );
+ $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
+ }
+ $self->_add_top_anchor(\$after);
+
+ if($self->html_javascript) {
+ my $link =
+ $self->html_javascript =~ m/</
+ ? $self->html_javascript # It's a big blob of markup, let's drop it in
+ : sprintf( # It's just a URL, so let's wrap it up
+ qq[<script type="text/javascript" src="%s"></script>\n],
+ $self->html_javascript,
+ );
+ $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
+ }
+
+ print {$self->{'output_fh'}}
+ $self->html_header_before_title || '',
+ $title, # already escaped
+ $after,
+ ;
+
+ DEBUG and print "Returning from do_beginning...\n";
+ return 1;
}
+sub _add_top_anchor {
+ my($self, $text_r) = @_;
+ unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack
+ $$text_r .= "<a name='___top' class='dummyTopAnchor' ></a>\n";
+ }
+ return;
+}
-sub resolve_pod_page_link {
- my($self, $to) = @_;
-
- return 'TODO';
+sub version_tag_comment {
+ my $self = shift;
+ return sprintf
+ "<!--\n generated by %s v%s,\n using %s v%s,\n under Perl v%s at %s GMT.\n\n %s\n\n-->\n",
+ esc(
+ ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(),
+ $], scalar(gmtime),
+ ), $self->_modnote(),
+ ;
}
-sub do_url_link { return $_[1]->attr('to') }
+sub _modnote {
+ my $class = ref($_[0]) || $_[0];
+ return join "\n " => grep m/\S/, split "\n",
-sub do_man_link { return undef }
- # But subclasses are welcome to override this if they have man
- # pages somewhere URL-accessible.
+qq{
+If you want to change this HTML document, you probably shouldn't do that
+by changing it directly. Instead, see about changing the calling options
+to $class, and/or subclassing $class,
+then reconverting this document from the Pod source.
+When in doubt, email the author of $class for advice.
+See 'perldoc $class' for more info.
+};
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+}
-sub do_link {
- my($self, $token) = @_;
- my $type = $token->attr('type');
- if(!defined $type) {
- $self->whine("Typeless L!?", $token->attr('start_line'));
- } elsif( $type eq 'pod') { return $self->do_pod_link($token);
- } elsif( $type eq 'url') { return $self->do_url_link($token);
- } elsif( $type eq 'man') { return $self->do_man_link($token);
- } else {
- $self->whine("L of unknown type $type!?", $token->attr('start_line'));
+sub do_end {
+ my $self = $_[0];
+ print {$self->{'output_fh'}} $self->html_footer || '';
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Normally this would just be a call to _do_middle_main_loop -- but we
+# have to do some elaborate things to emit all the content and then
+# summarize it and output it /before/ the content that it's a summary of.
+
+sub do_middle {
+ my $self = $_[0];
+ return $self->_do_middle_main_loop unless $self->index;
+
+ if( $self->output_string ) {
+ # An efficiency hack
+ my $out = $self->output_string; #it's a reference to it
+ my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n";
+ $$out .= $sneakytag;
+ $self->_do_middle_main_loop;
+ $sneakytag = quotemeta($sneakytag);
+ my $index = $self->index_as_html();
+ if( $$out =~ s/$sneakytag/$index/s ) {
+ # Expected case
+ DEBUG and print "Inserted ", length($index), " bytes of index HTML into $out.\n";
+ } else {
+ DEBUG and print "Odd, couldn't find where to insert the index in the output!\n";
+ # I don't think this should ever happen.
+ }
+ return 1;
+ }
+
+ unless( $self->output_fh ) {
+ require Carp;
+ Carp::confess("Parser object \$p doesn't seem to have any output object! I don't know how to deal with that.");
+ }
+
+ # If we get here, we're outputting to a FH. So we need to do some magic.
+ # Namely, divert all content to a string, which we output after the index.
+ my $fh = $self->output_fh;
+ my $content = '';
+ {
+ # Our horrible bait and switch:
+ $self->output_string( \$content );
+ $self->_do_middle_main_loop;
+ $self->abandon_output_string();
+ $self->output_fh($fh);
+ }
+ print $fh $self->index_as_html();
+ print $fh $content;
+
+ return 1;
+}
+
+###########################################################################
+
+sub index_as_html {
+ my $self = $_[0];
+ # This is meant to be called AFTER the input document has been parsed!
+
+ my $points = $self->{'PSHTML_index_points'} || [];
+
+ @$points > 1 or return qq[<div class='indexgroupEmpty'></div>\n];
+ # There's no point in having a 0-item or 1-item index, I dare say.
+
+ my(@out) = qq{\n<div class='indexgroup'>};
+ my $level = 0;
+
+ my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent);
+ foreach my $p (@$points, ['head0', '(end)']) {
+ ($tagname, $text) = @$p;
+ $anchorname = $self->section_escape($text);
+ if( $tagname =~ m{^head(\d+)$} ) {
+ $target_level = 0 + $1;
+ } else { # must be some kinda list item
+ if($previous_tagname =~ m{^head\d+$} ) {
+ $target_level = $level + 1;
+ } else {
+ $target_level = $level; # no change needed
+ }
+ }
+
+ # Get to target_level by opening or closing ULs
+ while($level > $target_level)
+ { --$level; push @out, (" " x $level) . "</ul>"; }
+ while($level < $target_level)
+ { ++$level; push @out, (" " x ($level-1))
+ . "<ul class='indexList indexList$level'>"; }
+
+ $previous_tagname = $tagname;
+ next unless $level;
+
+ $indent = ' ' x $level;
+ push @out, sprintf
+ "%s<li class='indexItem indexItem%s'><a href='#%s'>%s</a></li>",
+ $indent, $level, $anchorname, esc($text)
+ ;
}
- return 'FNORG';
+ push @out, "</div>\n";
+ return join "\n", @out;
}
+###########################################################################
-sub do_middle { # the main work
+sub _do_middle_main_loop {
my $self = $_[0];
my $fh = $self->{'output_fh'};
- my($token, $type, $tagname);
+ my($token, $type, $tagname, $linkto, $linktype);
my @stack;
my $dont_wrap = 0;
+
while($token = $self->get_token) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if( ($type = $token->type) eq 'start' ) {
if(($tagname = $token->tagname) eq 'L') {
- esc($type = $self->do_link($token)); # reuse it, why not
- if(defined $type and length $type) {
- print $fh "<a href='$type'>";
+ $linktype = $token->attr('type') || 'insane';
+
+ $linkto = $self->do_link($token);
+
+ if(defined $linkto and length $linkto) {
+ esc($linkto);
+ # (Yes, SGML-escaping applies on top of %-escaping!
+ # But it's rarely noticeable in practice.)
+ print $fh qq{<a href="$linkto" class="podlink$linktype"\n>};
} else {
print $fh "<a>"; # Yes, an 'a' element with no attributes!
}
@@ -228,19 +450,31 @@ sub do_middle { # the main work
push @to_unget, $self->get_token;
last if $to_unget[-1]->is_end
and $to_unget[-1]->tagname eq $tagname;
+
+ # TODO: support for X<...>'s found in here? (maybe hack into linearize_tokens)
}
+
my $name = $self->linearize_tokens(@to_unget);
- if(defined $name) { # ludicrously long, so nevermind
- $name =~ tr/ /_/;
- print $fh "<a name=\"", esc($name), "\"\n>";
+ print $fh "<a ";
+ print $fh "class='u' href='#___top' title='click to go to top of document'\n"
+ if $tagname =~ m/^head\d$/s;
+
+ if(defined $name) {
+ my $esc = esc( $self->section_name_tidy( $name ) );
+ print $fh qq[name="$esc"];
DEBUG and print "Linearized ", scalar(@to_unget),
" tokens as \"$name\".\n";
- } else {
- print $fh "<a\n>"; # Yes, an 'a' element with no attributes!
+ push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name]
+ if $ToIndex{ $tagname };
+ # Obviously, this discards all formatting codes (saving
+ # just their content), but ahwell.
+
+ } else { # ludicrously long, so nevermind
DEBUG and print "Linearized ", scalar(@to_unget),
" tokens, but it was too long, so nevermind.\n";
}
+ print $fh "\n>";
$self->unget_token(@to_unget);
} elsif ($tagname eq 'Data') {
@@ -286,87 +520,226 @@ sub do_middle { # the main work
return 1;
}
+###########################################################################
+#
+
+sub do_link {
+ my($self, $token) = @_;
+ my $type = $token->attr('type');
+ if(!defined $type) {
+ $self->whine("Typeless L!?", $token->attr('start_line'));
+ } elsif( $type eq 'pod') { return $self->do_pod_link($token);
+ } elsif( $type eq 'url') { return $self->do_url_link($token);
+ } elsif( $type eq 'man') { return $self->do_man_link($token);
+ } else {
+ $self->whine("L of unknown type $type!?", $token->attr('start_line'));
+ }
+ return 'FNORG'; # should never get called
+}
+
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-sub do_beginning {
- my $self = $_[0];
+sub do_url_link { return $_[1]->attr('to') }
+
+sub do_man_link { return undef }
+ # But subclasses are welcome to override this if they have man
+ # pages somewhere URL-accessible.
+
+
+sub do_pod_link {
+ # And now things get really messy...
+ my($self, $link) = @_;
+ my $to = $link->attr('to');
+ my $section = $link->attr('section');
+ return undef unless( # should never happen
+ (defined $to and length $to) or
+ (defined $section and length $section)
+ );
- my $title = $self->get_short_title();
- unless($self->content_seen) {
- DEBUG and print "No content seen in search for title.\n";
- return;
+ $section = $self->section_escape($section)
+ if defined $section and length($section .= ''); # (stringify)
+
+ DEBUG and printf "Resolving \"%s\" \"%s\"...\n",
+ $to || "(nil)", $section || "(nil)";
+
+ {
+ # An early hack:
+ my $complete_url = $self->resolve_pod_link_by_table($to, $section);
+ if( $complete_url ) {
+ DEBUG > 1 and print "resolve_pod_link_by_table(T,S) gives ",
+ $complete_url, "\n (Returning that.)\n";
+ return $complete_url;
+ } else {
+ DEBUG > 4 and print " resolve_pod_link_by_table(T,S)",
+ " didn't return anything interesting.\n";
+ }
}
- $self->{'Title'} = $title;
- esc($title);
- print {$self->{'output_fh'}}
- "<html><head>\n<title>$title</title>\n</head>\n<body>\n",
- $self->version_tag_comment,
- "<!-- start doc -->\n",
- ;
- # TODO: more configurability there
+ if(defined $to and length $to) {
+ # Give this routine first hack again
+ my $there = $self->resolve_pod_link_by_table($to);
+ if(defined $there and length $there) {
+ DEBUG > 1
+ and print "resolve_pod_link_by_table(T) gives $there\n";
+ } else {
+ $there =
+ $self->resolve_pod_page_link($to, $section);
+ # (I pass it the section value, but I don't see a
+ # particular reason it'd use it.)
+ DEBUG > 1 and print "resolve_pod_page_link gives ", $to || "(nil)", "\n";
+ unless( defined $there and length $there ) {
+ DEBUG and print "Can't resolve $to\n";
+ return undef;
+ }
+ # resolve_pod_page_link returning undef is how it
+ # can signal that it gives up on making a link
+ }
+ $to = $there;
+ }
- DEBUG and print "Returning from do_beginning...\n";
- return 1;
+ #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n";
+
+ my $out = (defined $to and length $to) ? $to : '';
+ $out .= "#" . $section if defined $section and length $section;
+
+ unless(length $out) { # sanity check
+ DEBUG and printf "Oddly, couldn't resolve \"%s\" \"%s\"...\n",
+ $to || "(nil)", $section || "(nil)";
+ return undef;
+ }
+
+ DEBUG and print "Resolved to $out\n";
+ return $out;
}
-sub version_tag_comment {
- my $self = shift;
- return sprintf
- "<!-- generated by %s v%s, using %s v%s, under Perl v%s at %s GMT -->\n",
- # None of the following things should need escaping, I dare say!
- ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(),
- $], scalar(gmtime),
- ;
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub section_escape {
+ my($self, $section) = @_;
+ return $self->section_url_escape(
+ $self->section_name_tidy($section)
+ );
}
+sub section_name_tidy {
+ my($self, $section) = @_;
+ $section =~ tr/ /_/;
+ $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters
+ $section = $self->unicode_escape_url($section);
+ $section = '_' unless length $section;
+ return $section;
+}
-sub do_end {
- my $self = $_[0];
- print {$self->{'output_fh'}} "\n<!-- end doc -->\n</body></html>\n";
- # TODO: allow for a footer
- return 1;
+sub section_url_escape { shift->general_url_escape(@_) }
+sub pagepath_url_escape { shift->general_url_escape(@_) }
+
+sub general_url_escape {
+ my($self, $string) = @_;
+
+ $string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg;
+ # express Unicode things as urlencode(utf(orig)).
+
+ # A pretty conservative escaping, behoovey even for query components
+ # of a URL (see RFC 2396)
+
+ $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done
+ # about that, I guess?
+
+ return $string;
}
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-sub esc {
- if(defined wantarray) {
- if(wantarray) {
- @_ = splice @_; # break aliasing
- } else {
- my $x = shift;
- $x =~ s/([^\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
- return $x;
- }
+#--------------------------------------------------------------------------
+#
+# Oh look, a yawning portal to Hell! Let's play touch football right by it!
+#
+
+sub resolve_pod_page_link {
+ # resolve_pod_page_link must return a properly escaped URL
+ my $self = shift;
+ return $self->batch_mode()
+ ? $self->resolve_pod_page_link_batch_mode(@_)
+ : $self->resolve_pod_page_link_singleton_mode(@_)
+ ;
+}
+
+sub resolve_pod_page_link_singleton_mode {
+ my($self, $it) = @_;
+ return undef unless defined $it and length $it;
+ my $url = $self->pagepath_url_escape($it);
+
+ $url =~ s{::$}{}s; # probably never comes up anyway
+ $url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM?
+
+ return undef unless length $url;
+ return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix;
+}
+
+sub resolve_pod_page_link_batch_mode {
+ my($self, $to) = @_;
+ DEBUG > 1 and print " During batch mode, resolving $to ...\n";
+ my @path = grep length($_), split m/::/s, $to, -1;
+ unless( @path ) { # sanity
+ DEBUG and print "Very odd! Splitting $to gives (nil)!\n";
+ return undef;
}
- foreach my $x (@_) {
- # Escape things very cautiously:
- $x =~ s/([^\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
- # Leave out "- so that "--" won't make it thru in X-generated comments
- # with text in them.
+ $self->batch_mode_rectify_path(\@path);
+ my $out = join('/', map $self->pagepath_url_escape($_), @path)
+ . $HTML_EXTENSION;
+ DEBUG > 1 and print " => $out\n";
+ return $out;
+}
- # Yes, stipulate the list without a range, so that this can work right on
- # all charsets that this module happens to run under.
- # Altho, hmm, what about that ord? Presumably that won't work right
- # under non-ASCII charsets. Something should be done about that.
+sub batch_mode_rectify_path {
+ my($self, $pathbits) = @_;
+ my $level = $self->batch_mode_current_level;
+ $level--; # how many levels up to go to get to the root
+ if($level < 1) {
+ unshift @$pathbits, '.'; # just to be pretty
+ } else {
+ unshift @$pathbits, ('..') x $level;
}
- return @_;
+ return;
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub resolve_pod_link_by_table {
+ # A crazy hack to allow specifying custom L<foo> => URL mappings
+
+ return unless $_[0]->{'podhtml_LOT'}; # An optimizy shortcut
+
+ my($self, $to, $section) = @_;
+
+ # TODO: add a method that actually populates podhtml_LOT from a file?
+
+ if(defined $section) {
+ $to = '' unless defined $to and length $to;
+ return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef!
+ } else {
+ return $self->{'podhtml_LOT'}{$to}; # quite possibly undef!
+ }
+ return;
+}
+
+###########################################################################
+
sub linearize_tokens { # self, tokens
my $self = shift;
my $out = '';
my $t;
while($t = shift @_) {
if(!ref $t or !UNIVERSAL::can($t, 'is_text')) {
- $out .= $t;
+ $out .= $t; # a string, or some insane thing
} elsif($t->is_text) {
$out .= $t->text;
} elsif($t->is_start and $t->tag eq 'X') {
- # ignore until the end of this X<...> sequence
+ # Ignore until the end of this X<...> sequence:
my $x_open = 1;
while($x_open) {
next if( ($t = shift @_)->is_text );
@@ -375,13 +748,7 @@ sub linearize_tokens { # self, tokens
}
}
}
-
- $out =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65);
return undef if length $out > $Linearization_Limit;
-
- $out = $self->unicode_escape_url($out);
- $out = '_' unless length $out;
-
return $out;
}
@@ -395,38 +762,104 @@ sub unicode_escape_url {
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub esc { # a function.
+ if(defined wantarray) {
+ if(wantarray) {
+ @_ = splice @_; # break aliasing
+ } else {
+ my $x = shift;
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
+ return $x;
+ }
+ }
+ foreach my $x (@_) {
+ # Escape things very cautiously:
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg
+ if defined $x;
+ # Leave out "- so that "--" won't make it thru in X-generated comments
+ # with text in them.
+
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done about that.
+ }
+ return @_;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1;
__END__
=head1 NAME
-TODO - TODO
+Pod::Simple::HTML - convert Pod to HTML
=head1 SYNOPSIS
- TODO
-
- perl -MPod::Simple::HTML -e \
- "exit Pod::Simple::HTML->filter(shift)->errors_seen" \
- thingy.pod
+ perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod
=head1 DESCRIPTION
-This class is for TODO.
+This class is for making an HTML rendering of a Pod document.
+
This is a subclass of L<Pod::Simple::PullParser> and inherits all its
-methods.
+methods (and options).
+
+Note that if you want to do a batch conversion of a lot of Pod
+documents to HTML, you should see the module L<Pod::Simple::HTMLBatch>.
+
+
+
+=head1 CALLING FROM THE COMMAND LINE
TODO
+ perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html
+
+
+
+=head1 CALLING FROM PERL
+
+TODO make a new object, set any options, and use parse_from_file
+
+
+=head1 METHODS
+
+TODO
+all (most?) accessorized methods
+
+
+=head1 SUBCLASSING
+
+TODO
+
+ can just set any of: html_css html_javascript title_prefix
+ 'html_header_before_title',
+ 'html_header_after_title',
+ 'html_footer',
+
+maybe override do_pod_link
+
+maybe override do_beginning do_end
+
+
+
=head1 SEE ALSO
-L<Pod::Simple>
+L<Pod::Simple>, L<Pod::Simple::HTMLBatch>
+
+
+TODO: a corpus of sample Pod input and HTML output? Or common
+idioms?
+
+
=head1 COPYRIGHT AND DISCLAIMERS
-Copyright (c) 2002 Sean M. Burke. All rights reserved.
+Copyright (c) 2002-2004 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
View
1,342 lib/Pod/Simple/HTMLBatch.pm
@@ -0,0 +1,1342 @@
+
+require 5;
+package Pod::Simple::HTMLBatch;
+use strict;
+use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION
+ $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA
+);
+$VERSION = '3.01';
+@ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML!
+
+# TODO: nocontents stylesheets. Strike some of the color variations?
+
+use Pod::Simple::HTML ();
+BEGIN {*esc = \&Pod::Simple::HTML::esc }
+use File::Spec ();
+use UNIVERSAL ();
+ # "Isn't the Universe an amazing place? I wouldn't live anywhere else!"
+
+use Pod::Simple::Search;
+$SEARCH_CLASS ||= 'Pod::Simple::Search';
+
+BEGIN {
+ if(defined &DEBUG) { } # no-op
+ elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
+ else { *DEBUG = sub () {0}; }
+}
+
+$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
+# flag to occasionally sleep for $SLEEPY - 1 seconds.
+
+$HTML_RENDER_CLASS ||= "Pod::Simple::HTML";
+
+#
+# Methods beginning with "_" are particularly internal and possibly ugly.
+#
+
+Pod::Simple::_accessorize( __PACKAGE__,
+ 'verbose', # how verbose to be during batch conversion
+ 'html_render_class', # what class to use to render
+ 'contents_file', # If set, should be the name of a file (in current directory)
+ # to write the list of all modules to
+ 'index', # will set $htmlpage->index(...) to this (true or false)
+ 'progress', # progress object
+ 'contents_page_start', 'contents_page_end',
+
+ 'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad',
+ 'no_contents_links', # set to true to suppress automatic adding of << links.
+ '_contents',
+);
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Just so we can run from the command line more easily
+sub go {
+ @ARGV == 2 or die sprintf(
+ "Usage: perl -M%s -e %s:go indirs outdir\n (or use \"\@INC\" for indirs)\n",
+ __PACKAGE__, __PACKAGE__,
+ );
+
+ if(defined($ARGV[1]) and length($ARGV[1])) {
+ my $d = $ARGV[1];
+ -e $d or die "I see no output directory named \"$d\"\nAborting";
+ -d $d or die "But \"$d\" isn't a directory!\nAborting";
+ -w $d or die "Directory \"$d\" isn't writeable!\nAborting";
+ }
+
+ __PACKAGE__->batch_convert(@ARGV);
+}
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
+sub new {
+ my $new = bless {}, ref($_[0]) || $_[0];
+ $new->html_render_class($HTML_RENDER_CLASS);
+ $new->verbose(1 + DEBUG);
+ $new->_contents([]);
+
+ $new->index(1);
+
+ $new-> _css_wad([]); $new->css_flurry(1);
+ $new->_javascript_wad([]); $new->javascript_flurry(1);
+
+ $new->contents_file(
+ 'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION)
+ );
+
+ $new->contents_page_start( join "\n", grep $_,
+ $Pod::Simple::HTML::Doctype_decl,
+ "<html><head>",
+ "<title>Perl Documentation</title>",
+ $Pod::Simple::HTML::Content_decl,
+ "</head>",
+ "\n<body class='contentspage'>\n<h1>Perl Documentation</h1>\n"
+ ); # override if you need a different title
+
+
+ $new->contents_page_end( sprintf(
+ "\n\n<p class='contentsfooty'>Generated by %s v%s under Perl v%s\n<br >At %s GMT, which is %s local time.</p>\n\n</body></html>\n",
+ esc(
+ ref($new),
+ eval {$new->VERSION} || $VERSION,
+ $], scalar(gmtime), scalar(localtime),
+ )));
+
+ return $new;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub muse {
+ my $self = shift;
+ if($self->verbose) {
+ print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n";
+ }
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub batch_convert {
+ my($self, $dirs, $outdir) = @_;
+ $self ||= __PACKAGE__; # tolerate being called as an optionless function
+ $self = $self->new unless ref $self; # tolerate being used as a class method
+
+ if(!defined($dirs) or $dirs eq '' or $dirs eq '@INC' ) {
+ $dirs = '';
+ } elsif(ref $dirs) {
+ # OK, it's an explicit set of dirs to scan, specified as an arrayref.
+ } else {
+ # OK, it's an explicit set of dirs to scan, specified as a
+ # string like "/thing:/also:/whatever/perl" (":"-delim, as usual)
+ # or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!)
+ require Config;
+ my $ps = quotemeta( $Config::Config{'path_sep'} || ":" );
+ $dirs = [ grep length($_), split qr/$ps/, $dirs ];
+ }
+
+ $outdir = $self->filespecsys->curdir
+ unless defined $outdir and length $outdir;
+
+ $self->_batch_convert_main($dirs, $outdir);
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _batch_convert_main {
+ my($self, $dirs, $outdir) = @_;
+ # $dirs is either false, or an arrayref.
+ # $outdir is a pathspec.
+
+ $self->{'_batch_start_time'} ||= time();
+
+ $self->muse( "= ", scalar(localtime) );
+ $self->muse( "Starting batch conversion to \"$outdir\"" );
+
+ my $progress = $self->progress;
+ if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) {
+ require Pod::Simple::Progress;
+ $progress = Pod::Simple::Progress->new(
+ ($self->verbose < 2) ? () # Default omission-delay
+ : ($self->verbose == 2) ? 1 # Reduce the omission-delay
+ : 0 # Eliminate the omission-delay
+ );
+ $self->progress($progress);
+ }
+
+ if($dirs) {
+ $self->muse(scalar(@$dirs), " dirs to scan: @$dirs");
+ } else {
+ $self->muse("Scanning \@INC. This could take a minute or two.");
+ }
+ my $mod2path = $self->find_all_pods($dirs ? $dirs : ());
+ $self->muse("Done scanning.");
+
+ my $total = keys %$mod2path;
+ unless($total) {
+ $self->muse("No pod found. Aborting batch conversion.\n");
+ return $self;
+ }
+
+ $progress and $progress->goal($total);
+ $self->muse("Now converting pod files to HTML.",
+ ($total > 25) ? " This will take a while more." : ()
+ );
+
+ $self->_spray_css( $outdir );
+ $self->_spray_javascript( $outdir );
+
+ $self->_do_all_batch_conversions($mod2path, $outdir);
+
+ $progress and $progress->done(sprintf (
+ "Done converting %d files.", $self->{"__batch_conv_page_count"}
+ ));
+ return $self->_batch_convert_finish($outdir);
+ return $self;
+}
+
+
+sub _do_all_batch_conversions {
+ my($self, $mod2path, $outdir) = @_;
+ $self->{"__batch_conv_page_count"} = 0;
+
+ foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) {
+ $self->_do_one_batch_conversion($module, $mod2path, $outdir);
+ sleep($SLEEPY - 1) if $SLEEPY;
+ }
+
+ return;
+}
+
+sub _batch_convert_finish {
+ my($self, $outdir) = @_;
+ $self->write_contents_file($outdir);
+ $self->muse("Done with batch conversion. $$self{'__batch_conv_page_count'} files done.");
+ $self->muse( "= ", scalar(localtime) );
+ $self->progress and $self->progress->done("All done!");
+ return;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _do_one_batch_conversion {
+ my($self, $module, $mod2path, $outdir, $outfile) = @_;
+
+ my $retval;
+ my $total = scalar keys %$mod2path;
+ my $infile = $mod2path->{$module};
+ my @namelets = grep m/\S/, split "::", $module;
+ # this can stick around in the contents LoL
+ my $depth = scalar @namelets;
+ die "Contentless thingie?! $module $infile" unless @namelets; #sanity
+
+ $outfile ||= do {
+ my @n = @namelets;
+ $n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION;
+ $self->filespecsys->catfile( $outdir, @n );
+ };
+
+ my $progress = $self->progress;
+
+ my $page = $self->html_render_class->new;
+ if(DEBUG > 5) {
+ $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ",
+ ref($page), " render ($depth) $module => $outfile");
+ } elsif(DEBUG > 2) {
+ $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile")
+ }
+
+ # Give each class a chance to init the converter:
+
+ $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
+ if $page->can('batch_mode_page_object_init');
+ $self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
+ if $self->can('batch_mode_page_object_init');
+
+ # Now get busy...
+ $self->makepath($outdir => \@namelets);
+
+ $progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module");
+
+ if( $retval = $page->parse_from_file($infile, $outfile) ) {
+ ++ $self->{"__batch_conv_page_count"} ;
+ $self->note_for_contents_file( \@namelets, $infile, $outfile );
+ } else {
+ $self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false.");
+ }
+
+ $page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth)
+ if $page->can('batch_mode_page_object_kill');
+ # The following isn't a typo. Note that it switches $self and $page.
+ $self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth)
+ if $self->can('batch_mode_page_object_kill');
+
+ DEBUG > 4 and printf "%s %sb < $infile %s %sb\n",
+ $outfile, -s $outfile, $infile, -s $infile
+ ;
+
+ undef($page);
+ return $retval;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' }
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub note_for_contents_file {
+ my($self, $namelets, $infile, $outfile) = @_;
+
+ # I think the infile and outfile parts are never used. -- SMB
+ # But it's handy to have them around for debugging.
+
+ if( $self->contents_file ) {
+ my $c = $self->_contents();
+ push @$c,
+ [ join("::", @$namelets), $infile, $outfile, $namelets ]
+ # 0 1 2 3
+ ;
+ DEBUG > 3 and print "Noting @$c[-1]\n";
+ }
+ return;
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub write_contents_file {
+ my($self, $outdir) = @_;
+ my $outfile = $self->_contents_filespec($outdir) || return;
+
+ $self->muse("Preparing list of modules for ToC");
+
+ my($toplevel, # maps toplevelbit => [all submodules]
+ $toplevel_form_freq, # ends up being 'foo' => 'Foo'
+ ) = $self->_prep_contents_breakdown;
+
+ my $Contents = eval { $self->_wopen($outfile) };
+ if( $Contents ) {
+ $self->muse( "Writing contents file $outfile" );
+ } else {
+ warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all";
+ return;
+ }
+
+ $self->_write_contents_start( $Contents, $outfile, );
+ $self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq );
+ $self->_write_contents_end( $Contents, $outfile, );
+ return $outfile;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _write_contents_start {
+ my($self, $Contents, $outfile) = @_;
+ my $starter = $self->contents_page_start || '';
+
+ {
+ my $css_wad = $self->_css_wad_to_markup(1);
+ if( $css_wad ) {
+ $starter =~ s{(</head>)}{\n$css_wad\n$1}i; # otherwise nevermind
+ }
+
+ my $javascript_wad = $self->_javascript_wad_to_markup(1);
+ if( $javascript_wad ) {
+ $starter =~ s{(</head>)}{\n$javascript_wad\n$1}i; # otherwise nevermind
+ }
+ }
+
+ unless(print $Contents $starter, "<dl class='superindex'>\n" ) {
+ warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
+ close($Contents);
+ return 0;
+ }
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _write_contents_middle {
+ my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_;
+
+ foreach my $t (sort keys %$toplevel2submodules) {
+ my @downlines = sort {$a->[-1] cmp $b->[-1]}
+ @{ $toplevel2submodules->{$t} };
+
+ printf $Contents qq[<dt><a name="%s">%s</a></dt>\n<dd>\n],
+ esc( $t, $toplevel_form_freq->{$t} )
+ ;
+
+ my($path, $name);
+ foreach my $e (@downlines) {
+ $name = $e->[0];
+ $path = join( "/", '.', esc( @{$e->[3]} ) )
+ . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION);
+ print $Contents qq{ <a href="$path">}, esc($name), "</a>&nbsp;&nbsp;\n";
+ }
+ print $Contents "</dd>\n\n";
+ }
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _write_contents_end {
+ my($self, $Contents, $outfile) = @_;
+ unless(
+ print $Contents "</dl>\n",
+ $self->contents_page_end || '',
+ ) {
+ warn "Couldn't write to $outfile: $!";
+ }
+ close($Contents) or warn "Couldn't close $outfile: $!";
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _prep_contents_breakdown {
+ my($self) = @_;
+ my $contents = $self->_contents;
+ my %toplevel; # maps lctoplevelbit => [all submodules]
+ my %toplevel_form_freq; # ends up being 'foo' => 'Foo'
+ # (mapping anycase forms to most freq form)
+
+ foreach my $entry (@$contents) {
+ my $toplevel =
+ $entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs'
+ # group all the perlwhatever docs together
+ : $entry->[3][0] # normal case
+ ;
+ ++$toplevel_form_freq{ lc $toplevel }{ $toplevel };
+ push @{ $toplevel{ lc $toplevel } }, $entry;
+ push @$entry, lc($entry->[0]); # add a sort-order key to the end
+ }
+
+ foreach my $toplevel (sort keys %toplevel) {
+ my $fgroup = $toplevel_form_freq{$toplevel};
+ $toplevel_form_freq{$toplevel} =
+ (
+ sort { $fgroup->{$b} <=> $fgroup->{$a} or $a cmp $b }
+ keys %$fgroup
+ # This hash is extremely unlikely to have more than 4 members, so this
+ # sort isn't so very wasteful
+ )[0];
+ }
+
+ return(\%toplevel, \%toplevel_form_freq) if wantarray;
+ return \%toplevel;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _contents_filespec {
+ my($self, $outdir) = @_;
+ my $outfile = $self->contents_file;
+ return unless $outfile;
+ return $self->filespecsys->catfile( $outdir, $outfile );
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub makepath {
+ my($self, $outdir, $namelets) = @_;
+ return unless @$namelets > 1;
+ for my $i (0 .. ($#$namelets - 1)) {
+ my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] );
+ if(-e $dir) {
+ die "$dir exists but not as a directory!?" unless -d $dir;
+ next;
+ }
+ DEBUG > 3 and print " Making $dir\n";
+ mkdir $dir, 0777
+ or die "Can't mkdir $dir: $!\nAborting"
+ ;
+ }
+ return;
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub batch_mode_page_object_init {
+ my $self = shift;
+ my($page, $module, $infile, $outfile, $depth) = @_;
+
+ # TODO: any further options to percolate onto this new object here?
+
+ $page->default_title($module);
+ $page->index( $self->index );
+
+ $page->html_css( $self-> _css_wad_to_markup($depth) );
+ $page->html_javascript( $self->_javascript_wad_to_markup($depth) );
+
+ $self->add_header_backlink($page, $module, $infile, $outfile, $depth);
+ $self->add_footer_backlink($page, $module, $infile, $outfile, $depth);
+
+
+ return $self;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub add_header_backlink {
+ my $self = shift;
+ return if $self->no_contents_links;
+ my($page, $module, $infile, $outfile, $depth) = @_;
+ $page->html_header_after_title( join '',
+ $page->html_header_after_title || '',
+
+ qq[<p class="backlinktop"><b><a name="___top" href="],
+ $self->url_up_to_contents($depth),
+ qq[" accesskey="1" title="All Documents">&lt;&lt;</a></b></p>\n],
+ )
+ if $self->contents_file
+ ;
+ return;
+}
+
+sub add_footer_backlink {
+ my $self = shift;
+ return if $self->no_contents_links;
+ my($page, $module, $infile, $outfile, $depth) = @_;
+ $page->html_footer( join '',
+ qq[<p class="backlinkbottom"><b><a name="___bottom" href="],
+ $self->url_up_to_contents($depth),
+ qq[" title="All Documents">&lt;&lt;</a></b></p>\n],
+
+ $page->html_footer || '',
+ )
+ if $self->contents_file
+ ;
+ return;
+}
+
+sub url_up_to_contents {
+ my($self, $depth) = @_;
+ --$depth;
+ return join '/', ('..') x $depth, esc($self->contents_file);
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub find_all_pods {
+ my($self, $dirs) = @_;
+ # You can override find_all_pods in a subclass if you want to
+ # do extra filtering or whatnot. But for the moment, we just
+ # pass to modnames2paths:
+ return $self->modnames2paths($dirs);
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub modnames2paths { # return a hashref mapping modulenames => paths
+ my($self, $dirs) = @_;
+
+ my $m2p;
+ {
+ my $search = $SEARCH_CLASS->new;
+ DEBUG and print "Searching via $search\n";
+ $search->verbose(1) if DEBUG > 10;
+ $search->progress( $self->progress->copy->goal(0) ) if $self->progress;
+ $search->shadows(0); # don't bother noting shadowed files
+ $search->inc( $dirs ? 0 : 1 );
+ $search->survey( $dirs ? @$dirs : () );
+ $m2p = $search->name2path;
+ die "What, no name2path?!" unless $m2p;
+ }
+
+ $self->muse("That's odd... no modules found!") unless keys %$m2p;
+ if( DEBUG > 4 ) {
+ print "Modules found (name => path):\n";
+ foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) {
+ print " $m $$m2p{$m}\n";
+ }
+ print "(total ", scalar(keys %$m2p), ")\n\n";
+ } elsif( DEBUG ) {
+ print "Found ", scalar(keys %$m2p), " modules.\n";
+ }
+ $self->muse( "Found ", scalar(keys %$m2p), " modules." );
+
+ # return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref
+ return $m2p;
+}
+
+#===========================================================================
+
+sub _wopen {
+ # this is abstracted out so that the daemon class can override it
+ my($self, $outpath) = @_;
+ require Symbol;
+ my $out_fh = Symbol::gensym();
+ DEBUG > 5 and print "Write-opening to $outpath\n";
+ return $out_fh if open($out_fh, "> $outpath");
+ require Carp;
+ Carp::croak("Can't write-open $outpath: $!");
+}
+
+#==========================================================================
+
+sub add_css {
+ my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_;
+ return unless $url;
+ unless($name) {
+ # cook up a reasonable name based on the URL
+ $name = $url;
+ if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) {
+ $name = $1;
+ $name =~ s/\.css//i;
+ }
+ }
+ $media ||= 'all';
+ $content_type ||= 'text/css';
+
+ my $bunch = [$url, $name, $content_type, $media, $_code];
+ if($is_default) { unshift @{ $self->_css_wad }, $bunch }
+ else { push @{ $self->_css_wad }, $bunch }
+ return;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _spray_css {
+ my($self, $outdir) = @_;
+
+ return unless $self->css_flurry();
+ $self->_gen_css_wad();
+
+ my $lol = $self->_css_wad;
+ foreach my $chunk (@$lol) {
+ my $url = $chunk->[0];
+ my $outfile;
+ if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) {
+ $outfile = $self->filespecsys->catfile( $outdir, $1 );
+ DEBUG > 5 and print "Noting $$chunk[0] as a file I'll create.\n";
+ } else {
+ DEBUG > 5 and print "OK, noting $$chunk[0] as an external CSS.\n";
+ # Requires no further attention.
+ next;
+ }
+
+ #$self->muse( "Writing autogenerated CSS file $outfile" );
+ my $Cssout = $self->_wopen($outfile);
+ print $Cssout ${$chunk->[-1]}
+ or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
+ close($Cssout);
+ DEBUG > 5 and print "Wrote $outfile\n";
+ }
+
+ return;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _css_wad_to_markup {
+ my($self, $depth) = @_;
+
+ my @css = @{ $self->_css_wad || return '' };
+ return '' unless @css;
+
+ my $rel = 'stylesheet';
+ my $out = '';
+
+ --$depth;
+ my $uplink = $depth ? ('../' x $depth) : '';
+
+ foreach my $chunk (@css) {
+ next unless $chunk and @$chunk;
+
+ my( $url1, $url2, $title, $type, $media) = (
+ $self->_maybe_uplink( $chunk->[0], $uplink ),
+ esc(grep !ref($_), @$chunk)
+ );
+
+ $out .= qq{<link rel="$rel" title="$title" type="$type" href="$url1$url2" media="$media" >\n};
+
+ $rel = 'alternate stylesheet'; # alternates = all non-first iterations
+ }
+ return $out;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+sub _maybe_uplink {
+ # if the given URL looks relative, return the given uplink string --
+ # otherwise return emptystring
+ my($self, $url, $uplink) = @_;
+ ($url =~ m{^\./} or $url !~ m{[/\:]} )
+ ? $uplink
+ : ''
+ # qualify it, if/as needed
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+sub _gen_css_wad {
+ my $self = $_[0];
+ my $css_template = $self->_css_template;
+ foreach my $variation (
+
+ # Commented out for sake of concision:
+ #
+ # 011n=black_with_red_on_white
+ # 001n=black_with_yellow_on_white
+ # 101n=black_with_green_on_white
+ # 110=white_with_yellow_on_black
+ # 010=white_with_green_on_black
+ # 011=white_with_blue_on_black
+ # 100=white_with_red_on_black
+
+ qw[
+ 110n=black_with_blue_on_white
+ 010n=black_with_magenta_on_white
+ 100n=black_with_cyan_on_white
+
+ 101=white_with_purple_on_black
+ 001=white_with_navy_blue_on_black
+
+ 010a=grey_with_green_on_black
+ 010b=white_with_green_on_grey
+ 101an=black_with_green_on_grey
+ 101bn=grey_with_green_on_white
+ ]) {
+
+ my $outname = $variation;
+ my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3)
+ if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s;
+ @swap = () if '010' eq join '', @swap; # 010 is a swop-no-op!
+
+ my $this_css =
+ "/* This file is autogenerated. Do not edit. $variation */\n\n"
+ . $css_template;
+
+ # Only look at three-digitty colors, for now at least.
+ if( $flipmode =~ m/n/ ) {
+ $this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg;
+ $this_css =~ s/\bthin\b/medium/g;
+ }
+ $this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b>
+ < join '', '#', ($1,$2,$3)[@swap] >eg if @swap;
+
+ if( $flipmode =~ m/a/)
+ { $this_css =~ s/#fff\b/#999/gi } # black -> dark grey
+ elsif($flipmode =~ m/b/)
+ { $this_css =~ s/#000\b/#666/gi } # white -> light grey
+
+ my $name = $outname;
+ $name =~ tr/-_/ /;
+ $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
+ }
+
+ # Now a few indexless variations:
+ foreach my $variation (qw[
+ black_with_blue_on_white white_with_purple_on_black
+ white_with_green_on_grey grey_with_green_on_white
+ ]) {
+ my $outname = "indexless_$variation";
+ my $this_css = join "\n",
+ "/* This file is autogenerated. Do not edit. $outname */\n",
+ "\@import url(\"./_$variation.css\");",
+ ".indexgroup { display: none; }",
+ "\n",
+ ;
+ my $name = $outname;
+ $name =~ tr/-_/ /;
+ $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
+ }
+
+ return;
+}
+
+sub _color_negate {
+ my $x = lc $_[0];
+ $x =~ tr[0123456789abcdef]
+ [fedcba9876543210];
+ return $x;
+}
+
+#===========================================================================
+
+sub add_javascript {
+ my($self, $url, $content_type, $_code) = @_;
+ return unless $url;
+ push @{ $self->_javascript_wad }, [
+ $url, $content_type || 'text/javascript', $_code
+ ];
+ return;
+}
+
+sub _spray_javascript {
+ my($self, $outdir) = @_;
+ return unless $self->javascript_flurry();
+ $self->_gen_javascript_wad();
+
+ my $lol = $self->_javascript_wad;
+ foreach my $script (@$lol) {
+ my $url = $script->[0];
+ my $outfile;
+
+ if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) {
+ $outfile = $self->filespecsys->catfile( $outdir, $1 );
+ DEBUG > 5 and print "Noting $$script[0] as a file I'll create.\n";
+ } else {
+ DEBUG > 5 and print "OK, noting $$script[0] as an external JavaScript.\n";
+ next;
+ }
+
+ #$self->muse( "Writing JavaScript file $outfile" );
+ my $Jsout = $self->_wopen($outfile);
+
+ print $Jsout ${$script->[-1]}
+ or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
+ close($Jsout);
+ DEBUG > 5 and print "Wrote $outfile\n";
+ }
+
+ return;
+}
+
+sub _gen_javascript_wad {
+ my $self = $_[0];
+ my $js_code = $self->_javascript || return;
+ $self->add_javascript( "_podly.js", 0, \$js_code);
+ return;
+}
+
+sub _javascript_wad_to_markup {
+ my($self, $depth) = @_;
+
+ my @scripts = @{ $self->_javascript_wad || return '' };
+ return '' unless @scripts;
+
+ my $out = '';
+
+ --$depth;
+ my $uplink = $depth ? ('../' x $depth) : '';
+
+ foreach my $s (@scripts) {
+ next unless $s and @$s;
+
+ my( $url1, $url2, $type, $media) = (
+ $self->_maybe_uplink( $s->[0], $uplink ),
+ esc(grep !ref($_), @$s)
+ );
+
+ $out .= qq{<script type="$type" src="$url1$url2"></script>\n};
+ }
+ return $out;
+}
+
+#===========================================================================
+
+sub _css_template { return $CSS }
+sub _javascript { return $JAVASCRIPT }
+
+$CSS = <<'EOCSS';
+/* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */
+
+@media all { .hide { display: none; } }
+
+@media print {
+ .noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none }
+
+ * {
+ border-color: black !important;
+ color: black !important;
+ background-color: transparent !important;
+ background-image: none !important;
+ }
+
+ dl.superindex > dd {
+ word-spacing: .6em;
+ }
+}
+
+@media aural, braille, embossed {
+ div.indexgroup { display: none; } /* Too noisy, don't you think? */
+ dl.superindex > dt:before { content: "Group "; }
+ dl.superindex > dt:after { content: " contains:"; }
+ .backlinktop a:before { content: "Back to contents"; }
+ .backlinkbottom a:before { content: "Back to contents"; }
+}
+
+@media aural {
+ dl.superindex > dt { pause-before: 600ms; }
+}
+
+@media screen, tty, tv, projection {
+ .noscreen { display: none; }
+
+ a:link { color: #7070ff; text-decoration: underline; }
+ a:visited { color: #e030ff; text-decoration: underline; }
+ a:active { color: #800000; text-decoration: underline; }
+ body.contentspage a { text-decoration: none; }
+ a.u { color: #fff !important; text-decoration: none; }
+
+ body.pod {
+ margin: 0 5px;
+ color: #fff;
+ background-color: #000;
+ }
+
+ body.pod h1, body.pod h2, body.pod h3, body.pod h4 {
+ font-family: Tahoma, Verdana, Helvetica, Arial, "sans-serif";
+ font-weight: normal;
+ margin-top: 1.2em;
+ margin-bottom: .1em;
+ border-top: thin solid transparent;
+ /* margin-left: -5px; border-left: 2px #7070ff solid; padding-left: 3px; */
+ }
+
+ body.pod h1 { border-top-color: #0a0; }
+ body.pod h2 { border-top-color: #080; }
+ body.pod h3 { border-top-color: #040; }
+ body.pod h4 { border-top-color: #010; }
+
+ p.backlinktop + h1 { border-top: none; margin-top: 0em; }
+ p.backlinktop + h2 { border-top: none; margin-top: 0em; }
+ p.backlinktop + h3 { border-top: none; margin-top: 0em; }
+ p.backlinktop + h4 { border-top: none; margin-top: 0em; }
+
+ body.pod dt {
+ font-size: 105%; # just a wee bit more than normal
+ }
+
+ .indexgroup { font-size: 80%; }
+
+ .backlinktop, .backlinkbottom {
+ margin-left: -5px;
+ margin-right: -5px;
+ background-color: #040;
+ border-top: thin solid #050;
+ border-bottom: thin solid #050;
+ }
+
+ .backlinktop a, .backlinkbottom a {
+ text-decoration: none;
+ color: #080;
+ background-color: #000;
+ border: thin solid #0d0;
+ }
+ .backlinkbottom { margin-bottom: 0; padding-bottom: 0; }
+ .backlinktop { margin-top: 0; padding-top: 0; }
+
+ body.contentspage {
+ color: #fff;
+ background-color: #000;
+ }
+
+ body.contentspage h1 {
+ color: #0d0;
+ margin-left: 1em;
+ margin-right: 1em;
+ text-indent: -.9em;
+ font-family: Tahoma, Verdana, Helvetica, Arial, "sans-serif";
+ font-weight: normal;
+ border-top: thin solid #fff;
+ border-bottom: thin solid #fff;
+ text-align: center;
+ }
+
+ dl.superindex > dt {
+ font-family: Tahoma, Verdana, Helvetica, Arial, "sans-serif";
+ font-weight: normal;
+ font-size: 90%;
+ margin-top: .45em;
+ /* margin-bottom: -.15em; */
+ }
+ dl.superindex > dd {
+ word-spacing: .6em; /* most important rule here! */
+ }
+ dl.superindex > a:link {
+ text-decoration: none;
+ color: #fff;
+ }
+
+ .contentsfooty {
+ border-top: thin solid #999;
+ font-size: 90%;
+ }
+
+}
+
+/* The End */
+
+EOCSS
+
+#==========================================================================
+
+$JAVASCRIPT = <<'EOJAVASCRIPT';
+
+// From http://www.alistapart.com/articles/alternate/
+
+function setActiveStyleSheet(title) {
+ var i, a, main;
+ for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
+ if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) {
+ a.disabled = true;
+ if(a.getAttribute("title") == title) a.disabled = false;
+ }
+ }
+}
+
+function getActiveStyleSheet() {
+ var i, a;
+ for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
+ if( a.getAttribute("rel").indexOf("style") != -1
+ && a.getAttribute("title")
+ && !a.disabled
+ ) return a.getAttribute("title");
+ }
+ return null;
+}
+
+function getPreferredStyleSheet() {
+ var i, a;
+ for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
+ if( a.getAttribute("rel").indexOf("style") != -1
+ && a.getAttribute("rel").indexOf("alt") == -1
+ && a.getAttribute("title")
+ ) return a.getAttribute("title");
+ }
+ return null;
+}
+
+function createCookie(name,value,days) {
+ if (days) {
+ var date = new Date();
+ date.setTime(date.getTime()+(days*24*60*60*1000));
+ var expires = "; expires="+date.toGMTString();
+ }
+ else expires = "";
+ document.cookie = name+"="+value+expires+"; path=/";
+}
+
+function readCookie(name) {
+ var nameEQ = name + "=";
+ var ca = document.cookie.split(';');
+ for(var i=0 ; i < ca.length ; i++) {
+ var c = ca[i];
+ while (c.charAt(0)==' ') c = c.substring(1,c.length);
+ if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length);
+ }
+ return null;
+}
+
+window.onload = function(e) {
+ var cookie = readCookie("style");
+ var title = cookie ? cookie : getPreferredStyleSheet();
+ setActiveStyleSheet(title);
+}
+
+window.onunload = function(e) {
+ var title = getActiveStyleSheet();
+ createCookie("style", title, 365);
+}
+
+var cookie = readCookie("style");
+var title = cookie ? cookie : getPreferredStyleSheet();
+setActiveStyleSheet(title);
+
+// The End
+
+EOJAVASCRIPT
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+1;
+__END__
+
+
+=head1 NAME
+
+Pod::Simple::HTMLBatch - convert several Pod files to several HTML files
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::HTMLBatch -e 'Pod::Simple::HTMLBatch::go' in out
+
+
+=head1 DESCRIPTION
+
+This module is used for running batch-conversions of a lot of HTML
+documents
+
+This class is NOT a subclass of Pod::Simple::HTML
+(nor of bad old Pod::Html) -- although it uses
+Pod::Simple::HTML for doing the conversion of each document.
+
+The normal use of this class is like so:
+
+ use Pod::Simple::HTMLBatch;
+ my $batchconv = Pod::Simple::HTMLBatch->new;
+ $batchconv->some_option( some_value );
+ $batchconv->some_other_option( some_other_value );
+ $batchconv->batch_convert( \@search_dirs, $output_dir );
+
+=head2 FROM THE COMMAND LINE
+
+Note that this class also provides
+(but does not export) the function Pod::Simple::HTMLBatch::go.
+This is basically just a shortcut for C<<
+Pod::Simple::HTMLBatch->batch_convert(@ARGV) >>.
+It's meant to be handy for calling from the command line.
+
+However, the shortcut requires that you specify exactly two command-line
+arguments, C<indirs> and C<outdir>.
+
+Example:
+
+ % mkdir out_html
+ % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html
+ (to convert the pod from Perl's @INC
+ files under the directory ../htmlversion)
+
+(Note that the command line there contains a literal atsign-I-N-C. This
+is handled as a special case by batch_convert, in order to save you having
+to enter the odd-looking "" as the first command-line parameter when you
+mean "just use whatever's in @INC".)
+
+Example:
+
+ % mkdir ../seekrut
+ % chmod og-rx ../seekrut
+ % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../htmlversion
+ (to convert the pod under the current dir into HTML
+ files under the directory ../htmlversion)
+
+Example:
+
+ % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go happydocs .
+ (to convert all pod from happydocs into the current directory)
+
+
+
+=head1 MAIN METHODS
+
+=over
+
+=item $batchconv = Pod::Simple::HTMLBatch->new;
+
+This TODO
+
+
+=item $batchconv->batch_convert( I<indirs>, I<outdir> );
+
+this TODO
+
+=item $batchconv->batch_convert( undef , ...);