Move Pod::Simple from ext/ to cpan/
[perl.git] / cpan / Pod-Simple / lib / Pod / Simple / HTMLBatch.pm
1
2 require 5;
3 package Pod::Simple::HTMLBatch;
4 use strict;
5 use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION
6  $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA
7 );
8 $VERSION = '3.02';
9 @ISA = ();  # Yup, we're NOT a subclass of Pod::Simple::HTML!
10
11 # TODO: nocontents stylesheets. Strike some of the color variations?
12
13 use Pod::Simple::HTML ();
14 BEGIN {*esc = \&Pod::Simple::HTML::esc }
15 use File::Spec ();
16 use UNIVERSAL ();
17   # "Isn't the Universe an amazing place?  I wouldn't live anywhere else!"
18
19 use Pod::Simple::Search;
20 $SEARCH_CLASS ||= 'Pod::Simple::Search';
21
22 BEGIN {
23   if(defined &DEBUG) { } # no-op
24   elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
25   else { *DEBUG = sub () {0}; }
26 }
27
28 $SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
29 # flag to occasionally sleep for $SLEEPY - 1 seconds.
30
31 $HTML_RENDER_CLASS ||= "Pod::Simple::HTML";
32
33 #
34 # Methods beginning with "_" are particularly internal and possibly ugly.
35 #
36
37 Pod::Simple::_accessorize( __PACKAGE__,
38  'verbose', # how verbose to be during batch conversion
39  'html_render_class', # what class to use to render
40  'contents_file', # If set, should be the name of a file (in current directory)
41                   # to write the list of all modules to
42  'index', # will set $htmlpage->index(...) to this (true or false)
43  'progress', # progress object
44  'contents_page_start',  'contents_page_end',
45
46  'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad',
47  'no_contents_links', # set to true to suppress automatic adding of << links.
48  '_contents',
49 );
50
51 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
52 # Just so we can run from the command line more easily
53 sub go {
54   @ARGV == 2 or die sprintf(
55     "Usage: perl -M%s -e %s:go indirs outdir\n  (or use \"\@INC\" for indirs)\n",
56     __PACKAGE__, __PACKAGE__, 
57   );
58   
59   if(defined($ARGV[1]) and length($ARGV[1])) {
60     my $d = $ARGV[1];
61     -e $d or die "I see no output directory named \"$d\"\nAborting";
62     -d $d or die "But \"$d\" isn't a directory!\nAborting";
63     -w $d or die "Directory \"$d\" isn't writeable!\nAborting";
64   }
65   
66   __PACKAGE__->batch_convert(@ARGV);
67 }
68 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
69
70
71 sub new {
72   my $new = bless {}, ref($_[0]) || $_[0];
73   $new->html_render_class($HTML_RENDER_CLASS);
74   $new->verbose(1 + DEBUG);
75   $new->_contents([]);
76   
77   $new->index(1);
78
79   $new->       _css_wad([]);         $new->css_flurry(1);
80   $new->_javascript_wad([]);  $new->javascript_flurry(1);
81   
82   $new->contents_file(
83     'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION)
84   );
85   
86   $new->contents_page_start( join "\n", grep $_,
87     $Pod::Simple::HTML::Doctype_decl,
88     "<html><head>",
89     "<title>Perl Documentation</title>",
90     $Pod::Simple::HTML::Content_decl,
91     "</head>",
92     "\n<body class='contentspage'>\n<h1>Perl Documentation</h1>\n"
93   ); # override if you need a different title
94   
95   
96   $new->contents_page_end( sprintf(
97     "\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",
98     esc(
99       ref($new),
100       eval {$new->VERSION} || $VERSION,
101       $], scalar(gmtime), scalar(localtime), 
102   )));
103
104   return $new;
105 }
106
107 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
108
109 sub muse {
110   my $self = shift;
111   if($self->verbose) {
112     print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n";
113   }
114   return 1;
115 }
116
117 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
118
119 sub batch_convert {
120   my($self, $dirs, $outdir) = @_;
121   $self ||= __PACKAGE__; # tolerate being called as an optionless function
122   $self = $self->new unless ref $self; # tolerate being used as a class method
123
124   if(!defined($dirs)  or  $dirs eq ''  or  $dirs eq '@INC' ) {
125     $dirs = '';
126   } elsif(ref $dirs) {
127     # OK, it's an explicit set of dirs to scan, specified as an arrayref.
128   } else {
129     # OK, it's an explicit set of dirs to scan, specified as a
130     #  string like "/thing:/also:/whatever/perl" (":"-delim, as usual)
131     #  or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!)
132     require Config;
133     my $ps = quotemeta( $Config::Config{'path_sep'} || ":" );
134     $dirs = [ grep length($_), split qr/$ps/, $dirs ];
135   }
136
137   $outdir = $self->filespecsys->curdir
138    unless defined $outdir and length $outdir;
139
140   $self->_batch_convert_main($dirs, $outdir);
141 }
142
143 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
144
145 sub _batch_convert_main {
146   my($self, $dirs, $outdir) = @_;
147   # $dirs is either false, or an arrayref.    
148   # $outdir is a pathspec.
149   
150   $self->{'_batch_start_time'} ||= time();
151
152   $self->muse( "= ", scalar(localtime) );
153   $self->muse( "Starting batch conversion to \"$outdir\"" );
154
155   my $progress = $self->progress;
156   if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) {
157     require Pod::Simple::Progress;
158     $progress = Pod::Simple::Progress->new(
159         ($self->verbose  < 2) ? () # Default omission-delay
160       : ($self->verbose == 2) ? 1  # Reduce the omission-delay
161                               : 0  # Eliminate the omission-delay
162     );
163     $self->progress($progress);
164   }
165   
166   if($dirs) {
167     $self->muse(scalar(@$dirs), " dirs to scan: @$dirs");
168   } else {
169     $self->muse("Scanning \@INC.  This could take a minute or two.");
170   }
171   my $mod2path = $self->find_all_pods($dirs ? $dirs : ());
172   $self->muse("Done scanning.");
173
174   my $total = keys %$mod2path;
175   unless($total) {
176     $self->muse("No pod found.  Aborting batch conversion.\n");
177     return $self;
178   }
179
180   $progress and $progress->goal($total);
181   $self->muse("Now converting pod files to HTML.",
182     ($total > 25) ? "  This will take a while more." : ()
183   );
184
185   $self->_spray_css(        $outdir );
186   $self->_spray_javascript( $outdir );
187
188   $self->_do_all_batch_conversions($mod2path, $outdir);
189
190   $progress and $progress->done(sprintf (
191     "Done converting %d files.",  $self->{"__batch_conv_page_count"}
192   ));
193   return $self->_batch_convert_finish($outdir);
194   return $self;
195 }
196
197
198 sub _do_all_batch_conversions {
199   my($self, $mod2path, $outdir) = @_;
200   $self->{"__batch_conv_page_count"} = 0;
201
202   foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) {
203     $self->_do_one_batch_conversion($module, $mod2path, $outdir);
204     sleep($SLEEPY - 1) if $SLEEPY;
205   }
206
207   return;
208 }
209
210 sub _batch_convert_finish {
211   my($self, $outdir) = @_;
212   $self->write_contents_file($outdir);
213   $self->muse("Done with batch conversion.  $$self{'__batch_conv_page_count'} files done.");
214   $self->muse( "= ", scalar(localtime) );
215   $self->progress and $self->progress->done("All done!");
216   return;
217 }
218
219 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
220
221 sub _do_one_batch_conversion {
222   my($self, $module, $mod2path, $outdir, $outfile) = @_;
223
224   my $retval;
225   my $total    = scalar keys %$mod2path;
226   my $infile   = $mod2path->{$module};
227   my @namelets = grep m/\S/, split "::", $module;
228         # this can stick around in the contents LoL
229   my $depth    = scalar @namelets;
230   die "Contentless thingie?! $module $infile" unless @namelets; #sanity
231     
232   $outfile  ||= do {
233     my @n = @namelets;
234     $n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION;
235     $self->filespecsys->catfile( $outdir, @n );
236   };
237
238   my $progress = $self->progress;
239
240   my $page = $self->html_render_class->new;
241   if(DEBUG > 5) {
242     $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ",
243       ref($page), " render ($depth) $module => $outfile");
244   } elsif(DEBUG > 2) {
245     $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile")
246   }
247
248   # Give each class a chance to init the converter:
249   
250   $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
251    if $page->can('batch_mode_page_object_init');
252   $self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
253    if $self->can('batch_mode_page_object_init');
254     
255   # Now get busy...
256   $self->makepath($outdir => \@namelets);
257
258   $progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module");
259
260   if( $retval = $page->parse_from_file($infile, $outfile) ) {
261     ++ $self->{"__batch_conv_page_count"} ;
262     $self->note_for_contents_file( \@namelets, $infile, $outfile );
263   } else {
264     $self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false.");
265   }
266
267   $page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth)
268    if $page->can('batch_mode_page_object_kill');
269   # The following isn't a typo.  Note that it switches $self and $page.
270   $self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth)
271    if $self->can('batch_mode_page_object_kill');
272     
273   DEBUG > 4 and printf "%s %sb < $infile %s %sb\n",
274      $outfile, -s $outfile, $infile, -s $infile
275   ;
276
277   undef($page);
278   return $retval;
279 }
280
281 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
282 sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' }
283
284 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
285
286 sub note_for_contents_file {
287   my($self, $namelets, $infile, $outfile) = @_;
288
289   # I think the infile and outfile parts are never used. -- SMB
290   # But it's handy to have them around for debugging.
291
292   if( $self->contents_file ) {
293     my $c = $self->_contents();
294     push @$c,
295      [ join("::", @$namelets), $infile, $outfile, $namelets ]
296      #            0               1         2         3
297     ;
298     DEBUG > 3 and print "Noting @$c[-1]\n";
299   }
300   return;
301 }
302
303 #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
304
305 sub write_contents_file {
306   my($self, $outdir) = @_;
307   my $outfile  = $self->_contents_filespec($outdir) || return;
308
309   $self->muse("Preparing list of modules for ToC");
310
311   my($toplevel,           # maps  toplevelbit => [all submodules]
312      $toplevel_form_freq, # ends up being  'foo' => 'Foo'
313     ) = $self->_prep_contents_breakdown;
314
315   my $Contents = eval { $self->_wopen($outfile) };
316   if( $Contents ) {
317     $self->muse( "Writing contents file $outfile" );
318   } else {
319     warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all";
320     return;
321   }
322
323   $self->_write_contents_start(  $Contents, $outfile, );
324   $self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq );
325   $self->_write_contents_end(    $Contents, $outfile, );
326   return $outfile;
327 }
328
329 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
330
331 sub _write_contents_start {
332   my($self, $Contents, $outfile) = @_;
333   my $starter = $self->contents_page_start || '';
334   
335   {
336     my $css_wad = $self->_css_wad_to_markup(1);
337     if( $css_wad ) {
338       $starter =~ s{(</head>)}{\n$css_wad\n$1}i;  # otherwise nevermind
339     }
340     
341     my $javascript_wad = $self->_javascript_wad_to_markup(1);
342     if( $javascript_wad ) {
343       $starter =~ s{(</head>)}{\n$javascript_wad\n$1}i;   # otherwise nevermind
344     }
345   }
346
347   unless(print $Contents $starter, "<dl class='superindex'>\n" ) {
348     warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
349     close($Contents);
350     return 0;
351   }
352   return 1;
353 }
354
355 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
356
357 sub _write_contents_middle {
358   my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_;
359
360   foreach my $t (sort keys %$toplevel2submodules) {
361     my @downlines = sort {$a->[-1] cmp $b->[-1]}
362                           @{ $toplevel2submodules->{$t} };
363     
364     printf $Contents qq[<dt><a name="%s">%s</a></dt>\n<dd>\n],
365       esc( $t, $toplevel_form_freq->{$t} )
366     ;
367     
368     my($path, $name);
369     foreach my $e (@downlines) {
370       $name = $e->[0];
371       $path = join( "/", '.', esc( @{$e->[3]} ) )
372         . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION);
373       print $Contents qq{  <a href="$path">}, esc($name), "</a>&nbsp;&nbsp;\n";
374     }
375     print $Contents "</dd>\n\n";
376   }
377   return 1;
378 }
379
380 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
381
382 sub _write_contents_end {
383   my($self, $Contents, $outfile) = @_;
384   unless(
385     print $Contents "</dl>\n",
386       $self->contents_page_end || '',
387   ) {
388     warn "Couldn't write to $outfile: $!";
389   }
390   close($Contents) or warn "Couldn't close $outfile: $!";
391   return 1;
392 }
393
394 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
395
396 sub _prep_contents_breakdown {
397   my($self) = @_;
398   my $contents = $self->_contents;
399   my %toplevel; # maps  lctoplevelbit => [all submodules]
400   my %toplevel_form_freq; # ends up being  'foo' => 'Foo'
401                                # (mapping anycase forms to most freq form)
402   
403   foreach my $entry (@$contents) {
404     my $toplevel = 
405       $entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs'
406           # group all the perlwhatever docs together
407       : $entry->[3][0] # normal case
408     ;
409     ++$toplevel_form_freq{ lc $toplevel }{ $toplevel };
410     push @{ $toplevel{ lc $toplevel } }, $entry;
411     push @$entry, lc($entry->[0]); # add a sort-order key to the end
412   }
413
414   foreach my $toplevel (sort keys %toplevel) {
415     my $fgroup = $toplevel_form_freq{$toplevel};
416     $toplevel_form_freq{$toplevel} =
417     (
418       sort { $fgroup->{$b} <=> $fgroup->{$a}  or  $a cmp $b }
419         keys %$fgroup
420       # This hash is extremely unlikely to have more than 4 members, so this
421       # sort isn't so very wasteful
422     )[0];
423   }
424
425   return(\%toplevel, \%toplevel_form_freq) if wantarray;
426   return \%toplevel;
427 }
428
429 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
430
431 sub _contents_filespec {
432   my($self, $outdir) = @_;
433   my $outfile = $self->contents_file;
434   return unless $outfile;
435   return $self->filespecsys->catfile( $outdir, $outfile );
436 }
437
438 #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
439
440 sub makepath {
441   my($self, $outdir, $namelets) = @_;
442   return unless @$namelets > 1;
443   for my $i (0 .. ($#$namelets - 1)) {
444     my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] );
445     if(-e $dir) {
446       die "$dir exists but not as a directory!?" unless -d $dir;
447       next;
448     }
449     DEBUG > 3 and print "  Making $dir\n";
450     mkdir $dir, 0777
451      or die "Can't mkdir $dir: $!\nAborting"
452     ;
453   }
454   return;
455 }
456
457 #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
458
459 sub batch_mode_page_object_init {
460   my $self = shift;
461   my($page, $module, $infile, $outfile, $depth) = @_;
462   
463   # TODO: any further options to percolate onto this new object here?
464
465   $page->default_title($module);
466   $page->index( $self->index );
467
468   $page->html_css(        $self->       _css_wad_to_markup($depth) );
469   $page->html_javascript( $self->_javascript_wad_to_markup($depth) );
470
471   $self->add_header_backlink($page, $module, $infile, $outfile, $depth);
472   $self->add_footer_backlink($page, $module, $infile, $outfile, $depth);
473
474
475   return $self;
476 }
477
478 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
479
480 sub add_header_backlink {
481   my $self = shift;
482   return if $self->no_contents_links;
483   my($page, $module, $infile, $outfile, $depth) = @_;
484   $page->html_header_after_title( join '',
485     $page->html_header_after_title || '',
486
487     qq[<p class="backlinktop"><b><a name="___top" href="],
488     $self->url_up_to_contents($depth),
489     qq[" accesskey="1" title="All Documents">&lt;&lt;</a></b></p>\n],
490   )
491    if $self->contents_file
492   ;
493   return;
494 }
495
496 sub add_footer_backlink {
497   my $self = shift;
498   return if $self->no_contents_links;
499   my($page, $module, $infile, $outfile, $depth) = @_;
500   $page->html_footer( join '',
501     qq[<p class="backlinkbottom"><b><a name="___bottom" href="],
502     $self->url_up_to_contents($depth),
503     qq[" title="All Documents">&lt;&lt;</a></b></p>\n],
504     
505     $page->html_footer || '',
506   )
507    if $self->contents_file
508   ;
509   return;
510 }
511
512 sub url_up_to_contents {
513   my($self, $depth) = @_;
514   --$depth;
515   return join '/', ('..') x $depth, esc($self->contents_file);
516 }
517
518 #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
519
520 sub find_all_pods {
521   my($self, $dirs) = @_;
522   # You can override find_all_pods in a subclass if you want to
523   #  do extra filtering or whatnot.  But for the moment, we just
524   #  pass to modnames2paths:
525   return $self->modnames2paths($dirs);
526 }
527
528 #_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
529
530 sub modnames2paths { # return a hashref mapping modulenames => paths
531   my($self, $dirs) = @_;
532
533   my $m2p;
534   {
535     my $search = $SEARCH_CLASS->new;
536     DEBUG and print "Searching via $search\n";
537     $search->verbose(1) if DEBUG > 10;
538     $search->progress( $self->progress->copy->goal(0) ) if $self->progress;
539     $search->shadows(0);  # don't bother noting shadowed files
540     $search->inc(     $dirs ? 0      :  1 );
541     $search->survey(  $dirs ? @$dirs : () );
542     $m2p = $search->name2path;
543     die "What, no name2path?!" unless $m2p;
544   }
545
546   $self->muse("That's odd... no modules found!") unless keys %$m2p;
547   if( DEBUG > 4 ) {
548     print "Modules found (name => path):\n";
549     foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) {
550       print "  $m  $$m2p{$m}\n";
551     }
552     print "(total ",     scalar(keys %$m2p), ")\n\n";
553   } elsif( DEBUG ) {
554     print      "Found ", scalar(keys %$m2p), " modules.\n";
555   }
556   $self->muse( "Found ", scalar(keys %$m2p), " modules." );
557   
558   # return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref
559   return $m2p;
560 }
561
562 #===========================================================================
563
564 sub _wopen {
565   # this is abstracted out so that the daemon class can override it
566   my($self, $outpath) = @_;
567   require Symbol;
568   my $out_fh = Symbol::gensym();
569   DEBUG > 5 and print "Write-opening to $outpath\n";
570   return $out_fh if open($out_fh, "> $outpath");
571   require Carp;  
572   Carp::croak("Can't write-open $outpath: $!");
573 }
574
575 #==========================================================================
576
577 sub add_css {
578   my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_;
579   return unless $url;
580   unless($name) {
581     # cook up a reasonable name based on the URL
582     $name = $url;
583     if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) {
584       $name = $1;
585       $name =~ s/\.css//i;
586     }
587   }
588   $media        ||= 'all';
589   $content_type ||= 'text/css';
590   
591   my $bunch = [$url, $name, $content_type, $media, $_code];
592   if($is_default) { unshift @{ $self->_css_wad }, $bunch }
593   else            { push    @{ $self->_css_wad }, $bunch }
594   return;
595 }
596
597 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
598
599 sub _spray_css {
600   my($self, $outdir) = @_;
601
602   return unless $self->css_flurry();
603   $self->_gen_css_wad();
604
605   my $lol = $self->_css_wad;
606   foreach my $chunk (@$lol) {
607     my $url = $chunk->[0];
608     my $outfile;
609     if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) {
610       $outfile = $self->filespecsys->catfile( $outdir, "$1" );
611       DEBUG > 5 and print "Noting $$chunk[0] as a file I'll create.\n";
612     } else {
613       DEBUG > 5 and print "OK, noting $$chunk[0] as an external CSS.\n";
614       # Requires no further attention.
615       next;
616     }
617     
618     #$self->muse( "Writing autogenerated CSS file $outfile" );
619     my $Cssout = $self->_wopen($outfile);
620     print $Cssout ${$chunk->[-1]}
621      or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
622     close($Cssout);
623     DEBUG > 5 and print "Wrote $outfile\n";
624   }
625
626   return;
627 }
628
629 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
630
631 sub _css_wad_to_markup {
632   my($self, $depth) = @_;
633   
634   my @css  = @{ $self->_css_wad || return '' };
635   return '' unless @css;
636   
637   my $rel = 'stylesheet';
638   my $out = '';
639
640   --$depth;
641   my $uplink = $depth ? ('../' x $depth) : '';
642
643   foreach my $chunk (@css) {
644     next unless $chunk and @$chunk;
645
646     my( $url1, $url2, $title, $type, $media) = (
647       $self->_maybe_uplink( $chunk->[0], $uplink ),
648       esc(grep !ref($_), @$chunk)
649     );
650
651     $out .= qq{<link rel="$rel" title="$title" type="$type" href="$url1$url2" media="$media" >\n};
652
653     $rel = 'alternate stylesheet'; # alternates = all non-first iterations
654   }
655   return $out;
656 }
657
658 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
659 sub _maybe_uplink {
660   # if the given URL looks relative, return the given uplink string --
661   # otherwise return emptystring
662   my($self, $url, $uplink) = @_;
663   ($url =~ m{^\./} or $url !~ m{[/\:]} )
664     ? $uplink
665     : ''
666     # qualify it, if/as needed
667 }
668
669 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
670 sub _gen_css_wad {
671   my $self = $_[0];
672   my $css_template = $self->_css_template;
673   foreach my $variation (
674
675    # Commented out for sake of concision:
676    #
677    #  011n=black_with_red_on_white
678    #  001n=black_with_yellow_on_white
679    #  101n=black_with_green_on_white
680    #  110=white_with_yellow_on_black
681    #  010=white_with_green_on_black
682    #  011=white_with_blue_on_black
683    #  100=white_with_red_on_black
684   
685    qw[
686     110n=black_with_blue_on_white
687     010n=black_with_magenta_on_white
688     100n=black_with_cyan_on_white
689
690     101=white_with_purple_on_black
691     001=white_with_navy_blue_on_black
692
693     010a=grey_with_green_on_black
694     010b=white_with_green_on_grey
695     101an=black_with_green_on_grey
696     101bn=grey_with_green_on_white
697   ]) {
698
699     my $outname = $variation;
700     my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3)
701       if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s;
702     @swap = () if '010' eq join '', @swap; # 010 is a swop-no-op!
703   
704     my $this_css =
705       "/* This file is autogenerated.  Do not edit.  $variation */\n\n"
706       . $css_template;
707
708     # Only look at three-digitty colors, for now at least.
709     if( $flipmode =~ m/n/ ) {
710       $this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg;
711       $this_css =~ s/\bthin\b/medium/g;
712     }
713     $this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b>
714                   < join '', '#', ($1,$2,$3)[@swap] >eg   if @swap;
715
716     if(   $flipmode =~ m/a/)
717        { $this_css =~ s/#fff\b/#999/gi } # black -> dark grey
718     elsif($flipmode =~ m/b/)
719        { $this_css =~ s/#000\b/#666/gi } # white -> light grey
720
721     my $name = $outname;    
722     $name =~ tr/-_/  /;
723     $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
724   }
725
726   # Now a few indexless variations:
727   foreach my $variation (qw[
728     black_with_blue_on_white  white_with_purple_on_black
729     white_with_green_on_grey  grey_with_green_on_white
730   ]) {
731     my $outname = "indexless_$variation";
732     my $this_css = join "\n",
733       "/* This file is autogenerated.  Do not edit.  $outname */\n",
734       "\@import url(\"./_$variation.css\");",
735       ".indexgroup { display: none; }",
736       "\n",
737     ;
738     my $name = $outname;    
739     $name =~ tr/-_/  /;
740     $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
741   }
742
743   return;
744 }
745
746 sub _color_negate {
747   my $x = lc $_[0];
748   $x =~ tr[0123456789abcdef]
749           [fedcba9876543210];
750   return $x;
751 }
752
753 #===========================================================================
754
755 sub add_javascript {
756   my($self, $url, $content_type, $_code) = @_;
757   return unless $url;
758   push  @{ $self->_javascript_wad }, [
759     $url, $content_type || 'text/javascript', $_code
760   ];
761   return;
762 }
763
764 sub _spray_javascript {
765   my($self, $outdir) = @_;
766   return unless $self->javascript_flurry();
767   $self->_gen_javascript_wad();
768
769   my $lol = $self->_javascript_wad;
770   foreach my $script (@$lol) {
771     my $url = $script->[0];
772     my $outfile;
773     
774     if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) {
775       $outfile = $self->filespecsys->catfile( $outdir, "$1" );
776       DEBUG > 5 and print "Noting $$script[0] as a file I'll create.\n";
777     } else {
778       DEBUG > 5 and print "OK, noting $$script[0] as an external JavaScript.\n";
779       next;
780     }
781     
782     #$self->muse( "Writing JavaScript file $outfile" );
783     my $Jsout = $self->_wopen($outfile);
784
785     print $Jsout ${$script->[-1]}
786      or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
787     close($Jsout);
788     DEBUG > 5 and print "Wrote $outfile\n";
789   }
790
791   return;
792 }
793
794 sub _gen_javascript_wad {
795   my $self = $_[0];
796   my $js_code = $self->_javascript || return;
797   $self->add_javascript( "_podly.js", 0, \$js_code);
798   return;
799 }
800
801 sub _javascript_wad_to_markup {
802   my($self, $depth) = @_;
803   
804   my @scripts  = @{ $self->_javascript_wad || return '' };
805   return '' unless @scripts;
806   
807   my $out = '';
808
809   --$depth;
810   my $uplink = $depth ? ('../' x $depth) : '';
811
812   foreach my $s (@scripts) {
813     next unless $s and @$s;
814
815     my( $url1, $url2, $type, $media) = (
816       $self->_maybe_uplink( $s->[0], $uplink ),
817       esc(grep !ref($_), @$s)
818     );
819
820     $out .= qq{<script type="$type" src="$url1$url2"></script>\n};
821   }
822   return $out;
823 }
824
825 #===========================================================================
826
827 sub _css_template { return $CSS }
828 sub _javascript   { return $JAVASCRIPT }
829
830 $CSS = <<'EOCSS';
831 /* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */
832
833 @media all { .hide { display: none; } }
834
835 @media print {
836   .noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none }
837
838   * {
839     border-color: black !important;
840     color: black !important;
841     background-color: transparent !important;
842     background-image: none !important;
843   }
844
845   dl.superindex > dd  {
846     word-spacing: .6em;
847   }
848 }
849
850 @media aural, braille, embossed {
851   div.indexgroup  { display: none; }  /* Too noisy, don't you think? */
852   dl.superindex > dt:before { content: "Group ";  }
853   dl.superindex > dt:after  { content: " contains:"; }
854   .backlinktop    a:before  { content: "Back to contents"; }
855   .backlinkbottom a:before  { content: "Back to contents"; }
856 }
857
858 @media aural {
859   dl.superindex > dt  { pause-before: 600ms; }
860 }
861
862 @media screen, tty, tv, projection {
863   .noscreen { display: none; }
864
865   a:link    { color: #7070ff; text-decoration: underline; }
866   a:visited { color: #e030ff; text-decoration: underline; }
867   a:active  { color: #800000; text-decoration: underline; }
868   body.contentspage a            { text-decoration: none; }
869   a.u { color: #fff !important; text-decoration: none; }
870
871   body.pod {
872     margin: 0 5px;
873     color:            #fff;
874     background-color: #000;
875   }
876
877   body.pod h1, body.pod h2, body.pod h3, body.pod h4  {
878     font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
879     font-weight: normal;
880     margin-top: 1.2em;
881     margin-bottom: .1em;
882     border-top: thin solid transparent;
883     /* margin-left: -5px;  border-left: 2px #7070ff solid;  padding-left: 3px; */
884   }
885   
886   body.pod h1  { border-top-color: #0a0; }
887   body.pod h2  { border-top-color: #080; }
888   body.pod h3  { border-top-color: #040; }
889   body.pod h4  { border-top-color: #010; }
890
891   p.backlinktop + h1 { border-top: none; margin-top: 0em;  }
892   p.backlinktop + h2 { border-top: none; margin-top: 0em;  }
893   p.backlinktop + h3 { border-top: none; margin-top: 0em;  }
894   p.backlinktop + h4 { border-top: none; margin-top: 0em;  }
895
896   body.pod dt {
897     font-size: 105%; /* just a wee bit more than normal */
898   }
899
900   .indexgroup { font-size: 80%; }
901
902   .backlinktop,   .backlinkbottom    {
903     margin-left:  -5px;
904     margin-right: -5px;
905     background-color:         #040;
906     border-top:    thin solid #050;
907     border-bottom: thin solid #050;
908   }
909   
910   .backlinktop a, .backlinkbottom a  {
911     text-decoration: none;
912     color: #080;
913     background-color:  #000;
914     border: thin solid #0d0;
915   }
916   .backlinkbottom { margin-bottom: 0; padding-bottom: 0; }
917   .backlinktop    { margin-top:    0; padding-top:    0; }
918
919   body.contentspage {
920     color:            #fff;
921     background-color: #000;
922   }
923   
924   body.contentspage h1  {
925     color:            #0d0;
926     margin-left: 1em;
927     margin-right: 1em;
928     text-indent: -.9em;
929     font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
930     font-weight: normal;
931     border-top:    thin solid #fff;
932     border-bottom: thin solid #fff;
933     text-align: center;
934   }
935
936   dl.superindex > dt  {
937     font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
938     font-weight: normal;
939     font-size: 90%;
940     margin-top: .45em;
941     /* margin-bottom: -.15em; */
942   }
943   dl.superindex > dd  {
944     word-spacing: .6em;    /* most important rule here! */
945   }
946   dl.superindex > a:link  {
947     text-decoration: none;
948     color: #fff;
949   }
950
951   .contentsfooty {
952     border-top: thin solid #999;
953     font-size: 90%;
954   }
955   
956 }
957
958 /* The End */
959
960 EOCSS
961
962 #==========================================================================
963
964 $JAVASCRIPT = <<'EOJAVASCRIPT';
965
966 // From http://www.alistapart.com/articles/alternate/
967
968 function setActiveStyleSheet(title) {
969   var i, a, main;
970   for(i=0  ;  (a = document.getElementsByTagName("link")[i])  ;  i++) {
971     if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) {
972       a.disabled = true;
973       if(a.getAttribute("title") == title) a.disabled = false;
974     }
975   }
976 }
977
978 function getActiveStyleSheet() {
979   var i, a;
980   for(i=0  ;  (a = document.getElementsByTagName("link")[i])  ;  i++) {
981     if(   a.getAttribute("rel").indexOf("style") != -1
982        && a.getAttribute("title")
983        && !a.disabled
984        ) return a.getAttribute("title");
985   }
986   return null;
987 }
988
989 function getPreferredStyleSheet() {
990   var i, a;
991   for(i=0  ;  (a = document.getElementsByTagName("link")[i])  ;  i++) {
992     if(   a.getAttribute("rel").indexOf("style") != -1
993        && a.getAttribute("rel").indexOf("alt") == -1
994        && a.getAttribute("title")
995        ) return a.getAttribute("title");
996   }
997   return null;
998 }
999
1000 function createCookie(name,value,days) {
1001   if (days) {
1002     var date = new Date();
1003     date.setTime(date.getTime()+(days*24*60*60*1000));
1004     var expires = "; expires="+date.toGMTString();
1005   }
1006   else expires = "";
1007   document.cookie = name+"="+value+expires+"; path=/";
1008 }
1009
1010 function readCookie(name) {
1011   var nameEQ = name + "=";
1012   var ca = document.cookie.split(';');
1013   for(var i=0  ;  i < ca.length  ;  i++) {
1014     var c = ca[i];
1015     while (c.charAt(0)==' ') c = c.substring(1,c.length);
1016     if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length);
1017   }
1018   return null;
1019 }
1020
1021 window.onload = function(e) {
1022   var cookie = readCookie("style");
1023   var title = cookie ? cookie : getPreferredStyleSheet();
1024   setActiveStyleSheet(title);
1025 }
1026
1027 window.onunload = function(e) {
1028   var title = getActiveStyleSheet();
1029   createCookie("style", title, 365);
1030 }
1031
1032 var cookie = readCookie("style");
1033 var title = cookie ? cookie : getPreferredStyleSheet();
1034 setActiveStyleSheet(title);
1035
1036 // The End
1037
1038 EOJAVASCRIPT
1039
1040 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1041 1;
1042 __END__
1043
1044
1045 =head1 NAME
1046
1047 Pod::Simple::HTMLBatch - convert several Pod files to several HTML files
1048
1049 =head1 SYNOPSIS
1050
1051   perl -MPod::Simple::HTMLBatch -e 'Pod::Simple::HTMLBatch::go' in out
1052
1053
1054 =head1 DESCRIPTION
1055
1056 This module is used for running batch-conversions of a lot of HTML
1057 documents 
1058
1059 This class is NOT a subclass of Pod::Simple::HTML
1060 (nor of bad old Pod::Html) -- although it uses
1061 Pod::Simple::HTML for doing the conversion of each document.
1062
1063 The normal use of this class is like so:
1064
1065   use Pod::Simple::HTMLBatch;
1066   my $batchconv = Pod::Simple::HTMLBatch->new;
1067   $batchconv->some_option( some_value );
1068   $batchconv->some_other_option( some_other_value );
1069   $batchconv->batch_convert( \@search_dirs, $output_dir );
1070
1071 =head2 FROM THE COMMAND LINE
1072
1073 Note that this class also provides
1074 (but does not export) the function Pod::Simple::HTMLBatch::go.
1075 This is basically just a shortcut for C<<
1076 Pod::Simple::HTMLBatch->batch_convert(@ARGV) >>.
1077 It's meant to be handy for calling from the command line.
1078
1079 However, the shortcut requires that you specify exactly two command-line
1080 arguments, C<indirs> and C<outdir>.
1081
1082 Example:
1083
1084   % mkdir out_html
1085   % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html
1086       (to convert the pod from Perl's @INC
1087        files under the directory ../htmlversion)
1088
1089 (Note that the command line there contains a literal atsign-I-N-C.  This
1090 is handled as a special case by batch_convert, in order to save you having
1091 to enter the odd-looking "" as the first command-line parameter when you
1092 mean "just use whatever's in @INC".)
1093
1094 Example:
1095
1096   % mkdir ../seekrut
1097   % chmod og-rx ../seekrut
1098   % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../htmlversion
1099       (to convert the pod under the current dir into HTML
1100        files under the directory ../htmlversion)
1101
1102 Example:
1103
1104   % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go happydocs .
1105       (to convert all pod from happydocs into the current directory)
1106
1107
1108
1109 =head1 MAIN METHODS
1110
1111 =over
1112
1113 =item $batchconv = Pod::Simple::HTMLBatch->new;
1114
1115 This TODO
1116
1117
1118 =item $batchconv->batch_convert( I<indirs>, I<outdir> );
1119
1120 this TODO
1121
1122 =item $batchconv->batch_convert( undef    , ...);
1123
1124 =item $batchconv->batch_convert( q{@INC}, ...);
1125
1126 These two values for I<indirs> specify that the normal Perl @INC
1127
1128 =item $batchconv->batch_convert( \@dirs , ...);
1129
1130 This specifies that the input directories are the items in
1131 the arrayref C<\@dirs>.
1132
1133 =item $batchconv->batch_convert( "somedir" , ...);
1134
1135 This specifies that the director "somedir" is the input.
1136 (This can be an absolute or relative path, it doesn't matter.)
1137
1138 A common value you might want would be just "." for the current
1139 directory:
1140
1141      $batchconv->batch_convert( "." , ...);
1142
1143
1144 =item $batchconv->batch_convert( 'somedir:someother:also' , ...);
1145
1146 This specifies that you want the dirs "somedir", "somother", and "also"
1147 scanned, just as if you'd passed the arrayref
1148 C<[qw( somedir someother also)]>.  Note that a ":"-separator is normal
1149 under Unix, but Under MSWin, you'll need C<'somedir;someother;also'>
1150 instead, since the pathsep on MSWin is ";" instead of ":".  (And
1151 I<that> is because ":" often comes up in paths, like
1152 C<"c:/perl/lib">.)
1153
1154 (Exactly what separator character should be used, is gotten from
1155 C<$Config::Config{'path_sep'}>, via the L<Config> module.)
1156
1157 =item $batchconv->batch_convert( ... , undef );
1158
1159 This specifies that you want the HTML output to go into the current
1160 directory.
1161
1162 (Note that a missing or undefined value means a different thing in
1163 the first slot than in the second.  That's so that C<batch_convert()>
1164 with no arguments (or undef arguments) means "go from @INC, into
1165 the current directory.)
1166
1167 =item $batchconv->batch_convert( ... , 'somedir' );
1168
1169 This specifies that you want the HTML output to go into the
1170 directory 'somedir'.
1171 (This can be an absolute or relative path, it doesn't matter.)
1172
1173 =back
1174
1175
1176 Note that you can also call C<batch_convert> as a class method,
1177 like so:
1178
1179   Pod::Simple::HTMLBatch->batch_convert( ... );
1180
1181 That is just short for this:
1182
1183   Pod::Simple::HTMLBatch-> new-> batch_convert(...);
1184
1185 That is, it runs a conversion with default options, for
1186 whatever inputdirs and output dir you specify.
1187
1188
1189 =head2 ACCESSOR METHODS
1190
1191 The following are all accessor methods -- that is, they don't do anything
1192 on their own, but just alter the contents of the conversion object,
1193 which comprises the options for this particular batch conversion.
1194
1195 We show the "put" form of the accessors below (i.e., the syntax you use
1196 for setting the accessor to a specific value).  But you can also
1197 call each method with no parameters to get its current value.  For
1198 example, C<< $self->contents_file() >> returns the current value of
1199 the contents_file attribute.
1200
1201 =over
1202
1203
1204 =item $batchconv->verbose( I<nonnegative_integer> );
1205
1206 This controls how verbose to be during batch conversion, as far as
1207 notes to STDOUT (or whatever is C<select>'d) about how the conversion
1208 is going.  If 0, no progress information is printed.
1209 If 1 (the default value), some progress information is printed.
1210 Higher values print more information.
1211
1212
1213 =item $batchconv->index( I<true-or-false> );
1214
1215 This controls whether or not each HTML page is liable to have a little
1216 table of contents at the top (which we call an "index" for historical
1217 reasons).  This is true by default.
1218
1219
1220 =item $batchconv->contents_file( I<filename> );
1221
1222 If set, should be the name of a file (in the output directory)
1223 to write the HTML index to.  The default value is "index.html".
1224 If you set this to a false value, no contents file will be written.
1225
1226 =item $batchconv->contents_page_start( I<HTML_string> );
1227
1228 This specifies what string should be put at the beginning of
1229 the contents page.
1230 The default is a string more or less like this:
1231   
1232   <html>
1233   <head><title>Perl Documentation</title></head>
1234   <body class='contentspage'>
1235   <h1>Perl Documentation</h1>
1236
1237 =item $batchconv->contents_page_end( I<HTML_string> );
1238
1239 This specifies what string should be put at the end of the contents page.
1240 The default is a string more or less like this:
1241
1242   <p class='contentsfooty'>Generated by
1243   Pod::Simple::HTMLBatch v3.01 under Perl v5.008
1244   <br >At Fri May 14 22:26:42 2004 GMT,
1245   which is Fri May 14 14:26:42 2004 local time.</p>
1246
1247
1248
1249 =item $batchconv->add_css( $url );
1250
1251 TODO
1252
1253 =item $batchconv->add_javascript( $url );
1254
1255 TODO
1256
1257 =item $batchconv->css_flurry( I<true-or-false> );
1258
1259 If true (the default value), we autogenerate some CSS files in the
1260 output directory, and set our HTML files to use those.
1261 TODO: continue
1262
1263 =item $batchconv->javascript_flurry( I<true-or-false> );
1264
1265 If true (the default value), we autogenerate a JavaScript in the
1266 output directory, and set our HTML files to use it.  Currently,
1267 the JavaScript is used only to get the browser to remember what
1268 stylesheet it prefers.
1269 TODO: continue
1270
1271 =item $batchconv->no_contents_links( I<true-or-false> );
1272
1273 TODO
1274
1275 =item $batchconv->html_render_class( I<classname> );
1276
1277 This sets what class is used for rendering the files.
1278 The default is "Pod::Simple::Search".  If you set it to something else,
1279 it should probably be a subclass of Pod::Simple::Search, and you should
1280 C<require> or C<use> that class so that's it's loaded before
1281 Pod::Simple::HTMLBatch tries loading it.
1282
1283 =back
1284
1285
1286
1287
1288 =head1 NOTES ON CUSTOMIZATION
1289
1290 TODO
1291
1292   call add_css($someurl) to add stylesheet as alternate
1293   call add_css($someurl,1) to add as primary stylesheet
1294
1295   call add_javascript
1296
1297   subclass Pod::Simple::HTML and set $batchconv->html_render_class to
1298     that classname
1299   and maybe override
1300     $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
1301   or maybe override
1302     $batchconv->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
1303
1304
1305
1306 =head1 ASK ME!
1307
1308 If you want to do some kind of big pod-to-HTML version with some
1309 particular kind of option that you don't see how to achieve using this
1310 module, email me (C<sburke@cpan.org>) and I'll probably have a good idea
1311 how to do it. For reasons of concision and energetic laziness, some
1312 methods and options in this module (and the dozen modules it depends on)
1313 are undocumented; but one of those undocumented bits might be just what
1314 you're looking for.
1315
1316
1317 =head1 SEE ALSO
1318
1319 L<Pod::Simple>, L<Pod::Simple::HTMLBatch>, L<perlpod>, L<perlpodspec>
1320
1321
1322
1323
1324 =head1 COPYRIGHT AND DISCLAIMERS
1325
1326 Copyright (c) 2004 Sean M. Burke.  All rights reserved.
1327
1328 This library is free software; you can redistribute it and/or modify it
1329 under the same terms as Perl itself.
1330
1331 This program is distributed in the hope that it will be useful, but
1332 without any warranty; without even the implied warranty of
1333 merchantability or fitness for a particular purpose.
1334
1335 =head1 AUTHOR
1336
1337 Sean M. Burke C<sburke@cpan.org>
1338
1339 =cut
1340
1341
1342