package ActivePerl::DocTools::TOC;

use strict;
use warnings;

use Config qw(%Config);
use File::Basename qw(fileparse);
use File::Find qw(find);

our $dirbase = $Config{installhtmldir} || "$Config{installprefix}/html";

my @core_pods = qw(
*Overview
  perl  perlintro  perltoc
-
*Tutorials
  perlreftut  perldsc  perllol
-
  perlrequick  perlretut
-
  perlboot  perltoot  perltooc  perlbot
-
  perlstyle
-
  perlcheat  perltrap  perldebtut
-
  perlfaq perlfaq1  perlfaq2  perlfaq3  perlfaq4  perlfaq5  perlfaq6
  perlfaq7  perlfaq8  perlfaq9
-
*Reference_Manual
  perlsyn  perldata  perlop  perlsub  perlfunc  perlopentut  perlpacktut
  perlpod  perlpodspec  perlrun  perldiag  perllexwarn  perldebug  perlvar
  perlre  perlrebackslash perlrecharclass perlreref  perlref  perlform  perlobj
  perltie  perldbmfilter
-
  perlipc  perlfork  perlnumber
-
  perlthrtut  perlothrtut
-
  perlport  perllocale  perluniintro  perlunicode  perlunifaq  perlunitut  perlebcdic
-
  perlsec
-
  perlmod  perlmodlib  perlmodstyle  perlmodinstall  perlnewmod perlpragma
-
  perlutil
-
  perlcompile
-
  perlfilter
-
  perlglossary
-
*Internals_and_C_Language_Interface
  perlembed  perldebguts  perlxstut  perlxs  perlclib  perlguts  perlcall
  perlreapi  perlreguts
-
  perlapi  perlintern  perliol  perlapio
-
  perlhack
-
*Miscellaneous
  perlbook  perlcommunity  perltodo
-
  perldoc
-
  perlhist  perldelta
  perl5104delta  perl5103delta  perl5102delta perl5101delta  perl5100delta
  perl595delta  perl594delta  perl593delta  perl592delta
  perl591delta perl590delta
  perl589delta  perl588delta  perl587delta  perl586delta  perl585delta
  perl584delta  perl583delta  perl582delta  perl581delta  perl58delta
  perl573delta  perl572delta  perl571delta  perl570delta
  perl561delta  perl56delta  perl5005delta  perl5004delta
-
  perlartistic  perlgpl
-
*Language-Specific
  perlcn  perljp  perlko  perltw
-
*Platform-Specific
  perlaix  perlamiga  perlapollo  perlbeos  perlbs2000  perlce  perlcygwin
  perldgux  perldos  perlepoc  perlfreebsd  perlhpux  perlhurd  perlirix  perllinux
  perlmachten  perlmacos  perlmacosx  perlmint  perlmpeix  perlnetware perlopenbsd
  perlos2  perlos390  perlos400  perlplan9  perlqnx  perlriscos  perlsolaris  perlsymbian
  perltru64  perluts  perlvmesa  perlvms  perlvos  perlwin32
);


# List of methods to override
for my $method (qw(
    header footer
    before_pods      pod      after_pods      pod_separator
    before_scripts   script   after_scripts
    before_pragmas   pragma   after_pragmas
    before_libraries library  after_libraries
    library_indent_open library_indent_close library_indent_same
    library_container))
{
    no strict "refs";
    *$method = sub {
	die "The subroutine $method() must be overriden by the child class"
    };
}


sub new {
    my($class, $options) = @_;
    my $self = $options ? $options : {};
    _BuildHashes($self);
    return bless($self, $class);
}


# generic structure for the website, HTML help, RDF
sub TOC {
    my($self) = @_;

    # generic header stuff
    my $output = $self->boilerplate;
    $output .= $self->header;

    # core pods
    $output .= $self->before_pods;

    my %unused_pods = %{$self->{pods}};
    foreach my $file (@core_pods) {
	next if $file =~ /^\*/;
	if ($file eq '-') {
	    $output .= $self->pod_separator;
	}
	elsif (delete $unused_pods{"Pod::$file"} || delete $unused_pods{"pods::$file"}) {
	    $output .= $self->pod($file);
	}
	else {
	    warn "Couldn't find pod for $file" if $self->{verbose};
	}
    }

    if ($self->{verbose}) {
	warn "Unused Pod: $_" for sort keys %unused_pods;
    }

    $output .= $self->after_pods;

    # scripts
    $output .= $self->before_scripts;
    $output .= $self->script($_) for sort {uc($a) cmp uc($b)} keys %{$self->{scripts}};
    $output .= $self->after_scripts;

    # pragmas
    $output .= $self->before_pragmas;
    $output .= $self->pragma($_) for sort keys %{$self->{pragmas}};
    $output .= $self->after_pragmas;

    # libraries
    $output .= $self->before_libraries;

    my $depth = 0;
    foreach my $file (sort {uc($a) cmp uc($b)} keys %{$self->{files}}) {
	my $showfile   = $file;
	my $file_depth = 0;
	my $depth_changed;

	# cuts $showfile down to its last part, i.e. Foo::Baz::Bar --> Bar
	# and counts the number of times, to get indent. --> 2
	$file_depth++ while $showfile =~ s/.*?::(.*)/$1/;

	while ($file_depth > $depth) {
	    $output .= $self->library_indent_open;
	    $depth++;
	    $depth_changed = 1;
	}
	while ($file_depth < $depth) {
	    $output .= $self->library_indent_close;
	    $depth--;
	    $depth_changed = 1;
	}

	$output .= $self->library_indent_same unless $depth_changed;

	if ($self->{files}->{$file}) {
	    $output .= $self->library($file, $showfile, $depth);
	}
	else {
	    # assume this is a containing item like a folder or something
	    $output .= $self->library_container($file, $showfile, $depth);
	}
    }

    $output .= $self->after_libraries;
    $output .= $self->footer;

    return $output;
}


sub _BuildHashes {
    my $self = shift;

    die "htmldir not found at: $dirbase" unless -d $dirbase;

    my @checkdirs = qw(bin lib site/lib);
    my (%files, %pragmas, %pods, %scripts);

    my $Process = sub {
	return if -d;
	my $parsefile = $_;

	my($filename,$dir,$suffix) = fileparse($parsefile,'\.html');

	if ($suffix !~ m#\.html#) { return; }

	my $TOCdir = $dir;

	$filename =~ s/(.*)\..*/$1/;

#    print "$TOCdir";
	my $ver = $Config{version};
	my $an = $Config{archname};
	if ($TOCdir =~ s#^.*?(bin/)(\Q$an\E/)?(.*)$#$3#) {
	    return if $filename eq "ppm3-bin";
	    return if $] >= 5.008 && $filename eq "ppm3";
	    return if $] < 5.008  && $filename eq "ppm";

	    $scripts{"$TOCdir$filename"} = "bin/$filename.html";
	    return 1;
	}
	$TOCdir =~ s#^.*?(lib/site_perl/\Q$ver\E/|lib/\Q$ver\E/|lib/)(\Q$an\E/)?(.*)$#$3#;
	$TOCdir =~ s#/#::#g;
	$TOCdir =~ s#^pod::#Pod::#; #Pod dir is uppercase in Win32
#    print " changed to: $TOCdir\n";
	$dir =~ s#.*?/((site/)?lib.*?)/$#$1#; #looks ugly to get around warning

	if ($files{"$TOCdir/$filename.html"}) {
	    warn "$parsefile: REPEATED!\n";
	}
	$files{"$TOCdir$filename"} = "$dir/$filename.html";
#    print "adding $parsefile as " . $files{"$TOCdir/$filename.html"} . "\n";
#    print "\%files{$TOCdir$filename.html}: " . $files{"$TOCdir$filename.html"} . "\n";

	return 1;
    };

    foreach my $dir (@checkdirs) {
	next unless -d "$dirbase/$dir";
	find({ wanted => $Process, no_chdir => 1 }, "$dirbase/$dir");
    }

    foreach my $file (keys %files) {
	if ($file =~ /^(Pod|pods)::perl/) {
	    $pods{$file} = delete $files{$file};
	}
	elsif ($file =~ /^(Pod|pods)::a2p/) {
	    $scripts{a2p} = delete $files{$file};
	}
	elsif ($file eq 'Pod::PerlEz'          ||
	       $file =~ /^(Pod|pods)::active/  ||
#	       $file =~ /^ActivePerl/          ||
#	       $file =~ /^ActiveState/         ||
	       $file =~ /^ASRemote/            ||
	       $file =~ /^PPM/)
        {
	    # these files are internal and support files
	    delete $files{$file};
	}
	elsif ($file =~ /^[a-z]/) {
	    if ($file ne 'perlfilter' &&
		$file ne 'lwpcook'    &&
		$file ne 'lwptut'     &&
                $file ne 'perl5db'    &&
		$file ne 'perllocal')
	    {
		$pragmas{$file} = delete $files{$file};
	    }
	}
    }

    foreach my $file (sort {uc($b) cmp uc($a)} keys %files) {
	my $prefix = $file;
	while ($prefix =~ s/(.*)?::(.*)/$1/) {
	    unless (defined ($files{$prefix})) {
		$files{$prefix} = '';
		warn "Added topic: $prefix\n" if $self->{verbose};
	    }
	    warn "$prefix from $file\n" if $self->{verbose};
	}
    }

    $self->{files}   = \%files;
    $self->{pods}    = \%pods;
    $self->{pragmas} = \%pragmas;
    $self->{scripts} = \%scripts;
}

1;