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 File::Spec::Functions;

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} );

    # Need absolule paths for pod_find.

    #   If in a symlink directory, then relative paths get confused

    my @podpathAbs = map { catdir($prefix, $_) } @$podpath;

    my %pods = pod_find(@podpathAbs);

    @$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;