htmlbatch.pm

source of perl for linux application,

    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 {