#!/usr/bin/perl -w
#
# perldoc2tree generates a tree of HTMLized documentation
# for all installed Perl modules and POD documentation.
#
# Usage:
#
#  perldoc2tree --target_dir=/www/yourserver/htdocs/perldocs \
#               --html_base=/perldocs
#
# You can optionally exclude pods or modules from the tree
# by using the --exclude option to specify one or more
# regular expressions to exclude.
#
# Example:
#
# perldoc2tree --target_dir=/www/yourserver/htdocs/perldocs \
#              --html_base=/perldocs \
#              --exclude=^PrivateModules
#
# NOTE: perldoc2tree is not meant to work as a CGI but from the
# command line. If you want to hack it to work as a CGI, fine - 
# but don't email me about it not working as CGI. That's
# because it *ISN'T* a CGI program.
#
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS
# OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
# PARTICULAR PURPOSE.
#
# Use of this software in any way or in any form, source or binary,
# is not allowed in any country which prohibits disclaimers of any
# implied warranties of merchantability or fitness for a particular
# purpose or any disclaimers of a similar nature.
#
# IN NO EVENT SHALL I BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT,
# SPECIAL, INCIDENTAL,  OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
# USE OF THIS SOFTWARE AND ITS DOCUMENTATION (INCLUDING, BUT NOT
# LIMITED TO, LOST PROFITS) EVEN IF I HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE
#
# Copyright September 2000, Benjamin Franz
#
# This software may be freely copied, changed or redistributed under 
# the same terms and conditions as Perl itself.

package NihongoOrg::PerlDoc2Tree;

use strict;
use Config;
use File::Find;
use File::Path;
use Pod::Html;
use Getopt::Long;
use vars qw($VERSION);

$VERSION="1.00";

my $html_base;
my $target_dir;
my $exclusions = [];

GetOptions(  'html_base=s' => \$html_base,
            'target_dir=s' => \$target_dir,
               'exclude=s' => $exclusions,
           );

if (! (defined ($html_base) && ($html_base ne ''))) {
    &usage;
    exit 1;
}

if (! (defined ($target_dir) && ($target_dir ne ''))) {
    &usage;
    exit 1;
}

if (! -e $target_dir) {
    die("--target_dir '$target_dir' does not exist\n");
}
if (! -d $target_dir) {
    die("--target_dir '$target_dir' is not a directory\n");
}
if ($#$exclusions > -1) {
    foreach (@$exclusions) {
        eval { qr/$_/ };
        if ($@) {
            die ("-exclude pattern '$_' is not a valid regex: $!");
        }
    }
}    

# Because pod2html is noisy as hell and doesn't need to be.
close(STDERR);

# You know, File::Find's usage semantics _really really_ suck....
my @SCRATCH_LIST;
my @module_dirs = grep(!/^$/,grep(!/^\.\.?$/,@INC));
$|++;
print "Scanning for modules and pod files";

my $modules = find_module_docs({ -module_dirs => \@module_dirs,
                                  -exclusions => $exclusions,
                                  });

print "\nGenerating documentation: ";

make_html_docs({ -target_dir => $target_dir,
                    -modules => $modules,
                  -html_root => $html_base,
          });
if (not -e "$target_dir/stylesheets") {
    if (not mkpath(["$target_dir/stylesheets"])) {
        die( "Unable to create $target_dir/stylesheets directory: $!\n");
    }
}
write_file("$target_dir/stylesheets/default.css",stylesheet());
print "Done.\n";

exit;

sub make_html_docs {
    my ($parms) = @_;
    my $target_dir = $parms->{-target_dir};
    chdir $target_dir;
    my $html_root   = $parms->{-html_root};
    my $modules     = $parms->{-modules};
    my $exclusions  = $parms->{-exclusions};
    my @sorted_list = sort keys %$modules;
    my $links       = {};
    my $files       = {};
    my $site_lib    = $Config{'sitelib'};
    foreach my $module_name (@sorted_list) {
        my $len = length($module_name);
        my $eraser = ("\x08" x $len) . (" " x $len) .("\x08" x $len) ;
        print $module_name;
        my $pod_file    = $modules->{$module_name}->{'-pod_file'};
        my $target_path = $module_name;
        $target_path    =~ s#::#/#g;
        $links->{$module_name} = "$target_path.html";
        $target_path    = "$target_dir/$target_path";
        my $parent_dir  = $target_path;
        $parent_dir     =~ s#/[^/]+$##;
        if (not -e $parent_dir) {
            if (not mkpath([$parent_dir])) {
                #warn("Unable to create '$parent_dir' directory: $!\n");
                print $eraser;
                next;
            }
        }
        my $output_file = "$target_path.html";
        # The calling semantics here suck as well
        pod2html( "--htmlroot=$html_root",
                    "--infile=$pod_file",
                   "--outfile=$output_file",
                   '--recurse',
                   "--title=$module_name",
                   "--podroot=$site_lib",
                   );
        if (not -e "$target_path.html") {
            print $eraser;
            next; 
        }
        fix_pod2html({ -file => $output_file,
                  -html_root => $html_root,
                    -modules => $modules,
                    });
        $files->{$module_name} = $output_file;
        print $eraser;
    }
    my @final_sorted_list = sort keys %$files;

    # Make the index
    open (INDEXFILE,">$target_dir/index.html") or die ("Unable to open $target_dir/index.html for writing:$!\n");
    print INDEXFILE <<"EOF";
<html>
 <head>
  <title>Perl Documentation</title>
 </head>
 <body bgcolor="#ffffff" text="#000000" link="#0000cc" alink="#cc0000" vlink="#800080">
 <h1 align="center">Perl Modules Documentation</h1>

 <table width="100%" border="1" cellspacing="0" cellpadding="0">
  <tr>
   <td align="left" valign="top">
    <ul>
EOF
    my $split_at = int (@final_sorted_list / 2) + 1;
    my $counter  = $split_at;
    foreach my $module_name (@final_sorted_list) {
        print INDEXFILE "     <li><a href=\"$links->{$module_name}\">$module_name</a></li>\n";
        $counter--;
        if ($counter <= 0) {
            print INDEXFILE "    </ul>\n   </td>\n   <td align=\"left\" valign=\"top\">\n    <ul>\n";
            $counter = $split_at;
        }
    }
    print INDEXFILE <<"EOFPAGE";
    </ul>
   </td>
  </tr>
 </table>
</body>
</html>
EOFPAGE
}

sub find_module_docs {
    my $parms = shift;
    my @module_libs = @{$parms->{-module_dirs}};
    my @exclusions  = @{$parms->{-exclusions}};

    my $exclusion_pattern;
    if ($#exclusions > -1) {
        my $bare_exclusion_pattern = join('|',@exclusions);
        $exclusion_pattern         = qr/$bare_exclusion_pattern/;
    }

	find(\&pm_files,@module_libs);
	my @escaped_prefixes = map { quotemeta($_) } @module_libs;

    my $archname = quotemeta($Config{'archname'});

	# Identify modules
	my $pod_files = {};
	foreach my $file (@SCRATCH_LIST) {
	    foreach my $module_dir (@escaped_prefixes) {
	       if ($file =~ m#^$module_dir/{0,}(.+)#) {
	            my $module_file = $1;
	            my $module_name = $module_file;
	            $module_name =~ s#/{2,}#/#g;
	            $module_name =~ s#/#::#g;
	            $module_name =~ s#\.(pm|pod)$##;
                $module_name =~ s#^${archname}::##o;
                next if ($exclusion_pattern && ($module_name =~ m/$exclusion_pattern/));
	            my ($type) = $module_file =~ m/\.(pm|pod)$/;
	            $pod_files->{$module_name}->{"-${type}_file"} = $file;
	            $pod_files->{$module_name}->{"-name"}         = $module_name;
	            last;
	       }
	    }
	}
	# Reconcile the 'pod' and 'pm' files
	foreach my $module_name (keys %$pod_files) {
	    if ((not exists $pod_files->{$module_name}->{'-pod_file'}) and
	        (exists $pod_files->{$module_name}->{'-pm_file'})) {
	         $pod_files->{$module_name}->{'-pod_file'} = $pod_files->{$module_name}->{'-pm_file'}
	    }
	}
    $pod_files;
}

sub pm_files {
    my $current_name = $File::Find::name;
    if ($current_name =~ m/\.(pm|pod)$/) {
        push (@SCRATCH_LIST,$current_name);
    }
}

sub fix_pod2html {
    my $parms = shift;
    my $file      = $parms->{-file};
    my $html_root = $parms->{-html_root};
    my $modules   = $parms->{-modules};

    my $text = read_file ($file);
    next if (not defined $text);

    # Fix Pod2HTML's idea of 'HTML' as much as possible
    my $fixed_text = fix_screwups({ -text => $text, -html_root => $html_root });

    # Hyperlink other modules we know about
    my @sorted_modules = sort { length($b) <=> length($a) } keys %$modules;
    foreach my $module_name (@sorted_modules) {
        my $link_to = $module_name;
        $link_to =~ s#::#/#g;
        $link_to = "<a href=\"$html_root/$link_to.html\">$module_name</a>";
        $fixed_text =~ s#\s$module_name\s# $link_to #g;
        $fixed_text =~ s#\s$module_name</p># $link_to</p>#g;
        $fixed_text =~ s#\s$module_name;# $link_to;#g;
    }

    # Save it
    write_file($file,$fixed_text);
}

sub read_file {
	my ($file) = @_;

	if (not open (FILE,$file))  {
		warn ("Could not open '$file' for reading\n$!");
		return undef;
	}
	local $/ = undef;
	my $text = <FILE>;
	close (FILE);

	$text;
}

sub write_file {
	my ($file,$text) = @_;

	if (not open (FILE,">$file"))  {
		warn ("Could not open '$file' for writing\n$!");
		return undef;
	}
	my $old_select = select (FILE);
	$|++;
	print $text;
	$|--;
	select $old_select;
	close (FILE);

	1;
}

sub fix_screwups {
    my $parms = shift;
	my $text      = $parms->{-text};
    my $html_root = $parms->{-html_root};

	my $doctype = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">';
	$_ = $text;

	# If I wanted my email address where a spam
	# bot could snag it, I'd put it in myself
	s/<LINK REV="made" HREF="mailto:[^"]+">//o;

	# =item C<$ui-E<gt>set_ui_mode($mode);>
	# WRONG WRONG WRONG!!!!! <STRONG> is illegal in <DT>. &gt; is the entity
	# for >. Failing to close <DT> screws up some HTML 'parsers'.
	# <DT><STRONG><A NAME="item__ui_gtset_ui_mode_mode_">$ui-gtset_ui_mode($mode);</A></STRONG><DD>
	# Right.
	# <dt><b><a name="item__ui_gtset_ui_mode_mode_">$ui-&gt;set_ui_mode($mode);</b></dt>\n<dd>
	s/-gt/-\&gt;/go;
	s#<DT><STRONG>#<dt><b>#go;
	s#</STRONG><DD>#</b></dt><dd>#go;

	# Close the <DD> tags. Stylesheets don't work
	# right in the Big Two with implied block closures.
	s#</DL>#</dd></dl>#go;

	# <P><HR> is nonsense code.
	s#<P>([^<]*)<P>\s+<HR>#<p>$1</p>\n<hr>#go;

	# So is <P><PRE>
	s#<P>([^<]*)<P>\s+<PRE>#<p>$1</p>\n<pre>#go;
	s#<P>\s*<PRE>#<pre>#goi;

	# close the dangling <P>
	s#<P>([^<]*)</dd>#<p>$1</p>\n</dd>#go;

	# <P> IS NOT equivalent to '\n\n'. Grrr.....
	s#<P>([^<]*)<P>#<p>$1</p>#oig;
	s#</p>([^<]*)<P>#</p><p>$1</p>#oig;
	s#</p>([^<]*)<DL>#</p><p>$1</p>\n<dl>#oig;
	s#\n</p>([^<]*)</p>#</p><p>$1</p>#oig;
	s#\n</p>([^<]*)</p>#</p><p>$1</p>#oig;
	s#\n</p>([^<]*)</p>#</p><p>$1</p>#oig;

	# close dangling <li>
	s#<UL>\s*<UL>#<ul>\n<li>\n<ul>#goi;
	s#</UL>\s*</UL>#</ul>\n</li>\n</ul>#goi;
	s#<LI><A HREF="([^"]*)">([^"]*)</A>(\s+)(?=<LI>)#<li><a href="$1">$2</a></li>$3#goi;
	s#</A>(\s+)</UL>#</a></li>$1</ul>#goi;
	s#</ul>(\s+)<li>#</ul></li>$1<li>#goi;

	# Gah.
	s#>\s+<P>\s+<HR>#>\n<hr>#go;
	s#<HR>\s+<P>\s+<H(\d)>#<hr>\n<h$1>#go;
	s#</H(\d)>\s+<P>\s+<HR>#</h$1>\n<hr>#go;

	# Patch up more P stuff
	s#([^\s>]+)\s*</dd>#$1\n</p></dd>#goi;
	s#([^\s>]+)\s*<dl>#$1\n</p>\n<dl>#goi;
	s#<P>\s*([^<]+)\s*<dl>#<p>$1</p>\n<dl>#goi;
	s#</CODE>(\s*)</dd>#</code>$1</p>\n</dd>#goi;
	s#</p>(\s*[^<\s])#</p><p>$1#goi;
	s#([^>\s])\s*<p>#$1</p><p>#goi;
	s#([^\s>]+)\s*</body>#$1</p>\n</body>#oi;

	s#<p>\s*<hr>#<hr>#gois;

    # Insert a H1 title
    my ($title) = m#<title>(.*?)</title>#i;
    s/<body>/<body bgcolor="#ffffff" text="#000000" link="#0000cc" alink="#cc0000" vlink="#800080">\n<h1>$title<\/h1>\n/is;
    # Install the stylesheet
    s#<body #<link rel="STYLESHEET" type="text/css" href="$html_root/stylesheets/default.css">\n<body #i;

	"$doctype\n$_";
}

sub stylesheet {
   my $style = <<"EOF";
A:link    { color : #0000cc;
       font-family: arial, helvetica, geneva, sans-serif;
			}
A:visited { color : #800080;
       font-family: arial, helvetica, geneva, sans-serif;
	   }
A:active  { color : #cc0000;
       font-family: arial, helvetica, geneva, sans-serif;
	   }
A:hover  { color : #6666ff;
               font-family: arial, helvetica, geneva, sans-serif;
	   }
CITE { color : #008000 }

body { background: #ffffff;
            color: #000000;
      font-family: arial, helvetica, geneva, sans-serif;
        font-size: 12pt;
     }

td {
        background: #ffffff;
             color: #000000;
       font-family: arial, helvetica, geneva, sans-serif;
         font-size: 12pt;
       font-weight: normal;
        font-style: normal;
     }
th {
        background: #ffffff;
             color: #000000;
       font-family: arial, helvetica, geneva, sans-serif;
         font-size: 12pt;
       font-weight: normal;
        font-style: normal;
     }
td.body {
        background: #ffffff;
             color: #000000;
       font-family: arial, helvetica, geneva, sans-serif;
         font-size: 12pt;
       font-weight: normal;
        font-style: normal;
		text-align: left;
	vertical-align: top;
}

h1         { font-size: 20pt;
                 color: #005870;
            font-style: normal;
           font-weight: normal;
           font-family: arial, helvetica, geneva, sans-serif;
            margin-top: 10;
            }
h2         { font-size: 16pt;
                 color: #005870;
           font-family: arial, helvetica, geneva, sans-serif;
           font-weight: bold;
            font-style: italic
           }

h3         { font-size: 14pt;
                 color: #005870;
            font-style: normal;
           font-family: arial, helvetica, geneva, sans-serif;
           font-weight: bold;
           }

h4         { margin-left: 0;
                   color: #900000;
               font-size: 12pt;
              font-style: normal;
             font-family: arial, helvetica, geneva, sans-serif;
             font-weight: bold;
             }

h5         { margin-left: 0;
                   color: #600000;
               font-size: 12pt;
              font-style: normal;
             font-family: arial, helvetica, geneva, sans-serif;
             font-weight: bold;
             }

h6         { margin-left: 0;
             color:       #500000;
             font-size:   12pt;
             font-family: roman;
             font-weight: bold; }

ul         { indent:        20;
              margin-left:  30;
             font-family: arial, helvetica, geneva, sans-serif;
              margin-top:    4;
              margin-bottom: 4;
              color:         #000000; }

dl         { margin-left: 3em;
             font-family: arial, helvetica, geneva, sans-serif;
}
dl dt      {
             font-family: arial, helvetica, geneva, sans-serif;
                   color:  #303080;
		   }

/h1 p/     { font-weight:    bold;
             font-family: arial, helvetica, geneva, sans-serif;
}
p          { margin-left:    1em;
             font-family: arial, helvetica, geneva, sans-serif;
             font-size:      12pt;}

address   {color:        #008000;
           text-align: left;
           margin-left: 3em;
             font-family: arial, helvetica, geneva, sans-serif;
           margin-right: 3em; }

b, strong { color: #487;
             font-family: arial, helvetica, geneva, sans-serif;
            font-weight: bold; }

i, em      { color: #487;
             font-family: arial, helvetica, geneva, sans-serif;
            style: italic; }

blockquote { color:      #202020;
             font-family: arial, helvetica, geneva, sans-serif;
             font-size:  10pt;
             margin-left: 50;
             margin-right: 50; }

table {
        font-family: arial, helvetica, geneva, sans-serif;
        margin-left: 0;
        margin-top: 0;
        margin-right: 0;
        margin-bottom: 0;
        padding-left: 0;
        padding-top: 0;
        padding-right: 0;
        padding-bottom: 0;
}
EOF
    $style;
}

sub usage {
    print STDERR <<"EOF";
Usage: $0 --html_base=/url/base --target_dir=/output/files/directory

Optionally, --exclude=regular_expression can be used to exclude modules
that you don't wish to have included in the output tree. Multiple
-exclude patterns are permitted.

Example:

$0 --html_base=/url/base --target_dir=/output/files/directory --exclude=^PrivateModules::

EOF
}