Subversion Repositories DevTools

package JatsDocTools::Tree::HTML;

use strict;
use warnings;

use Cwd qw(cwd);
use File::Basename qw(dirname);
use File::Path qw(mkpath);
use Pod::Find qw(pod_find);

use JatsDocTools::Pod qw(pod2html pod2html_remove_cache_files);

sub _relative_path {
    my($path, $prefix) = @_;
    $path =~ s,\\,/,g if $^O eq "MSWin32";
    $path =~ s,/\z,, unless $path =~ m,^([A-Za-z]:)?/\z,;

    if (defined $prefix && length $prefix) {
    $prefix =~ s,\\,/,g if $^O eq "MSWin32";
        $prefix =~ s,/\z,, unless $prefix =~ m,^([A-Za-z]:)?/\z,;

    my @path_parts   = split('/', $path);
    my @prefix_parts = split('/', $prefix);
    return $path if @path_parts < @prefix_parts;

    while (@prefix_parts) {
        my $path_part   = shift(@path_parts);
        my $prefix_part = shift(@prefix_parts);
        if ($^O eq "MSWin32") {
        $_ = lc for $path_part, $prefix_part;
        }
        return $path unless $path_part eq $prefix_part;
    }

    $path = join('/', @path_parts) || ".";
    }
    return $path;
}

sub Update {
    my %args = @_;

    my $prefix  = $args{prefix}  || croak("Required prefix argument missing");
    my $htmldir = $args{htmldir} || croak("Required htmldir argument missing");
    my $podpath = $args{podpath} || croak("Required podpath argument missing");
    my $cacheDir = $args{cacheDir} || croak("Required cacheDir argument missing");
    my $index = $args{index} || 0;

    my $starting_cwd = cwd();
    unless (chdir($prefix)) {
        warn "Can't chdir to root of target installation: $!\n";
        return;
    }

    print "Building HTML tree at $htmldir, cwd is $prefix\n" if $args{verbose};

    pod2html_remove_cache_files($cacheDir)
        if ( $args{force} );

    my %pods = pod_find(@$podpath);
    @$podpath = map { _relative_path($_, $prefix) } @$podpath;

    foreach my $key (sort keys %pods) {
        
        my $in_file = _relative_path($key, $prefix);
        if ( $in_file =~ m~TOOLS/LIB~ )
        {
            unless ( isaJatsKeyPod($in_file) ) {
                print "Ignoring $in_file\n" if $args{verbose};
                next;
            }
        }

        my $out_file = "$htmldir/$in_file";
        $out_file =~ s/\.[a-z]+\z|\z/.html/i;
        if ($args{force} || !-e $out_file || (stat $in_file)[9] > (stat $out_file)[9]) {
            print "Making $out_file from $in_file => $pods{$key}\n"
                if $args{verbose};

            unlink($out_file);
            my $out_dir = dirname($out_file);
            mkpath($out_dir);
            my $depth = $in_file =~ tr,/,,;
            pod2html(infile  => $in_file,
                     outfile => $out_file,
                     depth   => $depth,
                     podroot => ".",
                     podpath => $podpath,
                     cacheDir => $cacheDir,
                     index   => $index,
                     );
        }
        else {
            print "Skipping $out_file\n" if $args{verbose};
        }
    }

#    pod2html_remove_cache_files($cacheDir);
    chdir($starting_cwd) or die "Can't chdir back to '$starting_cwd': $!";
}

#-------------------------------------------------------------------------------
# Function        : isaJatsKeyPod  
#
# Description     : Test a specified file to see if its a Jats Key Documentation file
#                   Used to filter in POD inn cases where it might outherwise be excluded
#
#                   The test is simple
#                   If the file contains a POD section and that section contains the keyword
#                       =for htmltoc
#                   Then it is assumed that this file conatins JATS POD
#
# Inputs          : $fname      - Path to file to examine
#
# Returns         : True        - Include this file
#

sub isaJatsKeyPod
{
    my ($fname) = @_;
    my $podSeen;
    my $jatsKeyPod = 0;

    open (my $file, '<', $fname) || return 0;
    while (<$file>) 
    {
        if ( ! $podSeen) {
            if (m~^=pod~) {
                $podSeen = 1;
            }
            next;
        }

        if (m~^=head~) {
            last;
        }

        if ( m~^=for\s+htmltoc~ )
        {
            $jatsKeyPod = 1;
            last;
        }
    }

    close $file;
    return $jatsKeyPod;
}

1;