The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package PPT::Util;
# $Id: Util.pm,v 1.2 2004/08/05 14:24:55 cwest Exp $
use strict;

#BEGIN{sub Pod::Simple::DEBUG () {10} }
use base qw[Exporter];
use Config::General;
use IO::All;
use Pod::Simple::HTML;
use Carp;
use FindBin;
use CGI qw[:all];
use Template;

use vars qw[@EXPORT $BASE $CONFIG $HTML $SRC $V7DOC $HTMLSRC $TT
$TTWRAPPER $TEMPLATE $BIN $CFG $README];
@EXPORT = qw[config_read config_cmds create_cmd_doc copy_cmd_src
create_cmd_index copy_v7doc clean_html_dir generate_what generate_table
generate_page clean_bin_dir copy_dist_contrib];
$BASE      = "$FindBin::Bin/.."; # relative to $dist/util
$CONFIG    = "$BASE/data/index.cfg";
$HTML      = "$BASE/html";
$SRC       = "$BASE/src";
$V7DOC     = "$BASE/data/v7doc";
$HTMLSRC   = "$BASE/html-src";
$TT        = "$BASE/data/tt";
$TTWRAPPER = "$TT/wrapper.tt";
$BIN       = "$BASE/bin";
$README    = "$BASE/README"; do $README; # evil trick for easy version numbering
$TEMPLATE  = Template->new({
    PROCESS     => $TTWRAPPER,
    OUTPUT_PATH => $HTML,
    ABSOLUTE    => 1,
    VARIABLES   => { version => __PACKAGE__->VERSION },
});

sub config_read {
    my $config = shift || $CONFIG;
    $CFG = { ParseConfig(
        -ConfigFile           => $config,
        -LowerCaseNames       => 1,
        -AutoTrue             => 1,
    ) }
}

sub config_cmds {
    my $class = shift;
    config_read unless $CFG;
    my @cmds;
    foreach ( keys %{$CFG->{command}} ) {
        push @cmds, $_ if
          ($class ? ($CFG->{command}->{$_}->{class} eq $class) : 1);
    }
    return @cmds;
}

sub _cmd_contrib {
    my $cmd = shift;
    croak "Requires command" unless $cmd;
    config_read unless $CFG;

    my $contribs = $CFG->{command}->{$cmd}->{contrib};
    my @contrib = ();
       @contrib = ref($contribs) eq 'ARRAY' ? @{$contribs} : $contribs
         if $contribs;

    my ($basename) = $cmd =~ /(.+)\.\d+/;
    return (\@contrib, $basename);
}

sub create_cmd_doc {
    my ($contrib, $basename) = &_cmd_contrib;
    return unless @{$contrib};
    
    foreach ( @{$contrib} ) {
        mkdir "$HTML/commands/$basename";
        my $parse = Pod::Simple::HTML->new;
        my $out   = '';
        $parse->output_string(\$out);
        my $res;
        if ( -e "$SRC/$basename/$basename.pod" ) {
            $res = $parse->parse_file("$SRC/$basename/$basename.pod");
        } else {
            $res = $parse->parse_file("$SRC/$basename/$_->{name}");
        }

        io("$HTML/commands/$basename/$_->{name}.html")->print($out)
          if $res;
    }
}

sub copy_cmd_src {
    my ($contrib, $basename) = &_cmd_contrib;
    return unless @{$contrib};
    
    foreach ( @{$contrib} ) {
        mkdir "$HTML/commands/$basename";
        io("$SRC/$basename/$_->{name}") > io("$HTML/commands/$basename/$_->{name}");
        if ( $_->{support} ) {
          io("$SRC/$basename/$_") > io("$HTML/commands/$basename/$_")
            for split m/\s+/, $_->{support};
        }
    }
}

sub copy_v7doc {
    my $cmd = shift;
    croak "Requires command" unless $cmd;
    config_read unless $CFG;

    my ($basename) = $cmd =~ /(.+)\.\d+/;
    mkdir "$HTML/commands/$basename";
    io("$V7DOC/$cmd") > io("$HTML/commands/$basename/$cmd")
      if -e "$V7DOC/$cmd";
}

sub create_cmd_index {
    my ($contrib, $basename) = _cmd_contrib(@_);
    my ($section) = $_[0] =~ /(\d+)$/;

    foreach ( @{$contrib} ) {
        $_->{manpage} = (-s "$HTML/commands/$basename/$_->{name}.html" ? 1 : 0);
    }
    
    $TEMPLATE->process("$TT/command.tt", {
                           command => $basename,
                           contrib => $contrib,
                           v7      => (-e "$V7DOC/$_[0]" ? $_[0] : undef ),
                           name    => $_[0],
                       },
                       "commands/$basename/index.html") || die $TEMPLATE->error;
}

sub clean_html_dir {
    `find $HTML/commands/* -type f | grep -v CVS | xargs rm`; # I know, it's cheap.
    `rm $HTML/*.html`;
}

sub clean_bin_dir {
    `rm $BIN/*`;
}

sub _make_cmd_links {
    my @cmds = @_;

    my %list;
    foreach ( @cmds ) {
         my ($base) = $_ =~ /(.+)\.\d+$/;
         $list{$base} = @{(_cmd_contrib($_))[0]} ? 1 : 0;
    }
    %list;
}

sub generate_what {
    my %commands = _make_cmd_links( sort {$a cmp $b} config_cmds('command') );
    my %games    = _make_cmd_links( sort {$a cmp $b} config_cmds('game') );

    $TEMPLATE->process("$TT/what.tt", { commands => \%commands, games => \%games },
                       "what.html") || die $TEMPLATE->error;
}

sub generate_table {
    my @commands = sort {$a cmp $b} config_cmds;
    
    my @rows;
    foreach (@commands) {
        my ($contrib, $base) = _cmd_contrib($_);
        my @row = ($base);
        push @row, $CFG->{command}->{$_}->{class};
        push @row, [map $_->{author}, @{$contrib}];
        push @row, [map $_->{date}, @{$contrib}];
        push @row, @{$contrib} ? 'done' : 'missing';
        push @row, (grep{-e "$HTML/commands/$base/$_->{name}.html"}@{$contrib}) ? 'done' : 'missing';
        my @tests;
        foreach my $c ( @{$contrib} ) {
            $_ = $c;
            if ( $_->{test} ) {
                my @test = ref($_->{test}) eq 'HASH' ? $_->{test} : @{$_->{test}};
                $_->{command} = $c->{name} for @test;
                push @tests, @test;
            }
        }
        push @row, \@tests;
        push @rows, \@row;
    }

    $TEMPLATE->process("$TT/doneness.tt", { commands => \@rows }, 'doneness.html')
      || die $TEMPLATE->error;
}

sub generate_page {
    my $page_name = shift;
    my $original  = "$HTMLSRC/$page_name";
    
    $TEMPLATE->process($original, {}, $page_name)
      || die $TEMPLATE->error;
}

sub copy_dist_contrib {
    my ($contrib, $basename) = _cmd_contrib(@_);
    return unless @{$contrib};
    
    my $dist;
    if ( @{$contrib} > 1 ) {
        foreach ( @{$contrib} ) {
            $dist = $_->{name} and last if $_->{dist} && $_->{dist} == 1;
        }
    } else {
        $dist = $contrib->[0]->{name}
          unless exists $contrib->[0]->{dist} && $contrib->[0]->{dist} == 0;
    }
    return unless $dist;
    
    $dist = "$SRC/$basename/$dist";
    io($dist) > io("$BIN/$basename");
    chmod 0755, "$BIN/$basename";
}

1;