File Coverage

blib/lib/HTML/Latemp/GenMakeHelpers.pm

Criterion	Covered	Total	%
statement	172	182	94.5
branch	14	16	87.5
condition	12	16	75.0
subroutine	30	33	90.9
pod	8	8	100.0
total	236	255	92.5

package HTML::Latemp::GenMakeHelpers;
$HTML::Latemp::GenMakeHelpers::VERSION = '0.10.1';
use strict;
use warnings;
use autodie;
use 5.014;

package HTML::Latemp::GenMakeHelpers::Base;
$HTML::Latemp::GenMakeHelpers::Base::VERSION = '0.10.1';
sub new
{
    my $class = shift;
    my $self  = {};
    bless $self, $class;
    $self->initialize(@_);
    return $self;
}

package HTML::Latemp::GenMakeHelpers::HostEntry;
$HTML::Latemp::GenMakeHelpers::HostEntry::VERSION = '0.10.1';
our @ISA = (qw(HTML::Latemp::GenMakeHelpers::Base));

use Class::XSAccessor accessors =>
    { 'dest_dir' => 'dest_dir', 'id' => 'id', 'source_dir' => 'source_dir', };

sub initialize
{
    my $self = shift;
    my %args = (@_);

    $self->id( $args{'id'} );
    $self->source_dir( $args{'source_dir'} );
    $self->dest_dir( $args{'dest_dir'} );
}

package HTML::Latemp::GenMakeHelpers::Error;
$HTML::Latemp::GenMakeHelpers::Error::VERSION = '0.10.1';
our @ISA = (qw(HTML::Latemp::GenMakeHelpers::Base));

package HTML::Latemp::GenMakeHelpers::Error::UncategorizedFile;
$HTML::Latemp::GenMakeHelpers::Error::UncategorizedFile::VERSION = '0.10.1';
our @ISA = (qw(HTML::Latemp::GenMakeHelpers::Error));

use Class::XSAccessor accessors => { 'file' => 'file', 'host' => 'host', };

sub initialize
{
    my $self = shift;
    my $args = shift;

    $self->file( $args->{'file'} );
    $self->host( $args->{'host'} );

    return 0;
}

package HTML::Latemp::GenMakeHelpers;


our @ISA = (qw(HTML::Latemp::GenMakeHelpers::Base));

use File::Find::Rule ();
use File::Basename qw/ basename /;

use Class::XSAccessor accessors => {
    '_common_buckets'             => '_common_buckets',
    '_base_dir'                   => 'base_dir',
    '_filename_lists_post_filter' => '_filename_lists_post_filter',
    'hosts'                       => 'hosts',
    '_hosts_id_map'               => 'hosts_id_map',
    '_out_dir'                    => '_out_dir',
    '_out_docs_ext'               => '_out_docs_ext',
    '_docs_build_command_cb'      => '_docs_build_command_cb',
    '_images_dest_varname_cb'     => '_images_dest_varname_cb',
};


sub initialize
{
    my $self = shift;
    my (%args) = (@_);

    $self->_base_dir("src");
    $self->_filename_lists_post_filter(
        $args{filename_lists_post_filter} || sub {
            my ($params) = @_;
            return $params->{filenames};
        }
    );
    $self->hosts(
        [
            map { HTML::Latemp::GenMakeHelpers::HostEntry->new(%$_), }
                @{ $args{'hosts'} }
        ]
    );
    $self->_hosts_id_map( +{ map { $_->{'id'} => $_ } @{ $self->hosts() } } );
    $self->_common_buckets( {} );
    $self->_out_dir( $args{'out_dir'} );
    $self->_out_docs_ext( $args{'out_docs_ext'} // '.wml' );
    $self->_docs_build_command_cb( $args{'docs_build_command_cb'} );
    $self->_images_dest_varname_cb( $args{'images_dest_varname_cb'} );

    return;
}

sub _calc_out_path
{
    my ( $self, $bn ) = @_;

    my $out_dir = $self->_out_dir;

    return $out_dir ? File::Spec->catfile( $out_dir, $bn ) : $bn;
}

sub process_all
{
    my $self = shift;
    my $dir  = $self->_base_dir();

    my @hosts = @{ $self->hosts() };

    open my $file_lists_fh, ">", $self->_calc_out_path("include.mak");
    open my $rules_fh,      ">", $self->_calc_out_path("rules.mak");

    print {$rules_fh} "COMMON_SRC_DIR = "
        . $self->_hosts_id_map()->{'common'}->{'source_dir'} . "\n\n";

    foreach my $host (@hosts)
    {
        my $host_outputs = $self->process_host($host);
        print {$file_lists_fh} $host_outputs->{'file_lists'};
        print {$rules_fh} $host_outputs->{'rules'};
    }

    print {$rules_fh} "latemp_targets: "
        . join( " ",
        map  { '$(' . uc( $_->{'id'} ) . "_TARGETS)" }
        grep { $_->{'id'} ne "common" } @hosts )
        . "\n\n";

    close($rules_fh);
    close($file_lists_fh);
}

sub _make_path
{
    my $self = shift;

    my $host = shift;
    my $path = shift;

    return $host->source_dir() . "/" . $path;
}


sub get_initial_buckets
{
    my $self = shift;
    my $host = shift;

    return [
        {
            'name'   => "IMAGES",
            'filter' => sub {
                my $fn = shift;
                return ( $fn !~ /\.(?:tt|w)ml\z/ )
                    && ( -f $self->_make_path( $host, $fn ) );
            },
        },
        {
            'name'   => "DIRS",
            'filter' => sub {
                return ( -d $self->_make_path( $host, shift ) );
            },
            filter_out_common => 1,
        },
        {
            'name'   => "DOCS",
            'filter' => sub {
                return shift =~ /\.x?html\.wml\z/;
            },
            'map' => sub {
                my $fn = shift;
                $fn =~ s{\.wml\z}{};
                return $fn;
            },
        },
        {
            'name'   => "TTMLS",
            'filter' => sub {
                return shift =~ /\.ttml\z/;
            },
            'map' => sub {
                my $fn = shift;
                $fn =~ s{\.ttml\z}{};
                return $fn;
            },
        },
    ];
}

sub _identity
{
    return shift;
}

sub _process_bucket
{
    my ( $self, $bucket ) = @_;
    return {
        %$bucket,
        'results' => [],
        (
              ( !exists( $bucket->{'map'} ) )
            ? ( 'map' => \&_identity )
            : ()
        ),
    };
}


sub get_buckets
{
    my ( $self, $host ) = @_;

    return [ map { $self->_process_bucket($_) }
            @{ $self->get_initial_buckets($host) } ];
}

sub _filter_out_special_files
{
    my ( $self, $host, $files_ref ) = @_;

    my @files = @$files_ref;

    @files = ( grep { !m{(\A|/)\.svn(/|\z)} } @files );
    @files = ( grep { !/~\z/ } @files );
    @files = (
        grep {
            my $bn = basename($_);
            not( ( $bn =~ /\A\./ ) && ( $bn =~ /\.swp\z/ ) )
        } @files
    );

    return \@files;
}

sub _sort_files
{
    my ( $self, $host, $files_ref ) = @_;

    return [ sort { $a cmp $b } @$files_ref ];
}


sub get_non_bucketed_files
{
    my ( $self, $host ) = @_;

    my $source_dir_path = $host->source_dir();

    my $files = [ File::Find::Rule->in($source_dir_path) ];

    s!^$source_dir_path/!! for @$files;
    $files = [ grep { $_ ne $source_dir_path } @$files ];

    $files = $self->_filter_out_special_files( $host, $files );

    return $self->_sort_files( $host, $files );
}


sub place_files_into_buckets
{
    my ( $self, $host, $files, $buckets ) = @_;

FILE_LOOP:
    foreach my $f (@$files)
    {
        foreach my $bucket (@$buckets)
        {
            if ( $bucket->{'filter'}->($f) )
            {
                if ( $host->{'id'} eq "common" )
                {
                    $self->_common_buckets->{ $bucket->{name} }->{$f} = 1;
                }

                if (
                    ( $host->{'id'} eq "common" )
                    || (
                        !(
                            $bucket->{'filter_out_common'} && exists(
                                $self->_common_buckets->{ $bucket->{name} }
                                    ->{$f}
                            )
                        )
                    )
                    )
                {
                    push @{ $bucket->{'results'} }, $bucket->{'map'}->($f);
                }

                next FILE_LOOP;
            }
        }
        die HTML::Latemp::GenMakeHelpers::Error::UncategorizedFile->new(
            {
                'file' => $f,
                'host' => $host->id(),
            }
        );
    }
}


sub get_rules_template
{
    my ( $self, $host ) = @_;

    my $h_dest_star = "\$(X8X_DEST)/%";
    my $wml_path =
qq{WML_LATEMP_PATH="\$\$(perl -MFile::Spec -e 'print File::Spec->rel2abs(shift)' '\$\@')"};
    my $dest_dir        = $host->dest_dir();
    my $source_dir_path = $host->source_dir();
    my $out_docs_ext    = $self->_out_docs_ext;

    my ( $common_cmd, $no_common_cmd );
    if ( my $cb = $self->_docs_build_command_cb )
    {
        $common_cmd    = $cb->( $self, { host => $host, is_common => 1, } );
        $no_common_cmd = $cb->( $self, { host => $host, is_common => '', } );
    }
    else
    {
        $common_cmd =
qq#$wml_path ; ( cd \$(COMMON_SRC_DIR) && wml -o "\$\${WML_LATEMP_PATH}" \$(X8X_WML_FLAGS) -DLATEMP_FILENAME=\$(patsubst $h_dest_star,%,\$(patsubst %${out_docs_ext},%,\$@)) \$(patsubst \$(COMMON_SRC_DIR)/%,%,\$<) )#;
        $no_common_cmd =
qq#$wml_path ; ( cd \$(X8X_SRC_DIR) && wml -o "\$\${WML_LATEMP_PATH}" \$(X8X_WML_FLAGS) -DLATEMP_FILENAME=\$(patsubst $h_dest_star,%,\$(patsubst %${out_docs_ext},%,\$@)) \$(patsubst \$(X8X_SRC_DIR)/%,%,\$<) )#;
    }
    my ( $common_images_dest, $no_common_images_dest );
    if ( my $cb = $self->_images_dest_varname_cb )
    {
        $common_images_dest =
            $cb->( $self, { host => $host, is_common => 1, } );
        $no_common_images_dest =
            $cb->( $self, { host => $host, is_common => '', } );
    }
    else
    {
        $no_common_images_dest = $common_images_dest = 'X8X_DEST';
    }
    my $ci_h_dest_star  = "\$($common_images_dest)/%";
    my $nci_h_dest_star = "\$($no_common_images_dest)/%";
    return <<"EOF";

X8X_SRC_DIR := $source_dir_path

X8X_DEST := $dest_dir

X8X_WML_FLAGS := \$(WML_FLAGS) -DLATEMP_SERVER=x8x

X8X_TTML_FLAGS := \$(TTML_FLAGS) -DLATEMP_SERVER=x8x

X8X_DOCS_DEST := \$(patsubst %,\$(X8X_DEST)/%,\$(X8X_DOCS))

X8X_DIRS_DEST := \$(patsubst %,\$(X8X_DEST)/%,\$(X8X_DIRS))

X8X_IMAGES_DEST := \$(patsubst %,\$($no_common_images_dest)/%,\$(X8X_IMAGES))

X8X_TTMLS_DEST := \$(patsubst %,\$(X8X_DEST)/%,\$(X8X_TTMLS))

X8X_COMMON_IMAGES_DEST := \$(patsubst %,\$($common_images_dest)/%,\$(COMMON_IMAGES))

X8X_COMMON_DIRS_DEST := \$(patsubst %,\$(X8X_DEST)/%,\$(COMMON_DIRS))

X8X_COMMON_TTMLS_DEST := \$(patsubst %,\$(X8X_DEST)/%,\$(COMMON_TTMLS))

X8X_COMMON_DOCS_DEST := \$(patsubst %,\$(X8X_DEST)/%,\$(COMMON_DOCS))

X8X_TARGETS := \$(X8X_DEST) \$(X8X_DIRS_DEST) \$(X8X_COMMON_DIRS_DEST) \$(X8X_COMMON_IMAGES_DEST) \$(X8X_COMMON_DOCS_DEST) \$(X8X_COMMON_TTMLS_DEST) \$(X8X_IMAGES_DEST) \$(X8X_DOCS_DEST) \$(X8X_TTMLS_DEST)

\$(X8X_DOCS_DEST) : $h_dest_star : \$(X8X_SRC_DIR)/%${out_docs_ext} \$(DOCS_COMMON_DEPS)
	$no_common_cmd

\$(X8X_TTMLS_DEST) : $h_dest_star : \$(X8X_SRC_DIR)/%.ttml \$(TTMLS_COMMON_DEPS)
	ttml -o \$@ \$(X8X_TTML_FLAGS) -DLATEMP_FILENAME=\$(patsubst $h_dest_star,%,\$(patsubst %.ttml,%,\$@)) \$<

\$(X8X_DIRS_DEST) : $h_dest_star :
	mkdir -p \$@
	touch \$@

\$(X8X_IMAGES_DEST) : $nci_h_dest_star : \$(X8X_SRC_DIR)/%
	\$(call LATEMP_COPY)

\$(X8X_COMMON_IMAGES_DEST) : $ci_h_dest_star : \$(COMMON_SRC_DIR)/%
	\$(call LATEMP_COPY)

\$(X8X_COMMON_TTMLS_DEST) : $h_dest_star : \$(COMMON_SRC_DIR)/%.ttml \$(TTMLS_COMMON_DEPS)
	ttml -o \$@ \$(X8X_TTML_FLAGS) -DLATEMP_FILENAME=\$(patsubst $h_dest_star,%,\$(patsubst %.ttml,%,\$@)) \$<

\$(X8X_COMMON_DOCS_DEST) : $h_dest_star : \$(COMMON_SRC_DIR)/%${out_docs_ext} \$(DOCS_COMMON_DEPS)
	$common_cmd

\$(X8X_COMMON_DIRS_DEST)  : $h_dest_star :
	mkdir -p \$@
	touch \$@

\$(X8X_DEST):
	mkdir -p \$@
	touch \$@
EOF
}


sub process_host
{
    my $self = shift;
    my $host = shift;

    my $dir = $self->_base_dir();

    my $source_dir_path = $host->source_dir();

    my $file_lists_text = "";
    my $rules_text      = "";

    my $files = $self->get_non_bucketed_files($host);

    my $buckets = $self->get_buckets($host);

    $self->place_files_into_buckets( $host, $files, $buckets );

    my $id      = $host->id();
    my $host_uc = uc($id);
    foreach my $bucket (@$buckets)
    {
        my $name = $bucket->{name};
        $file_lists_text .=
              $host_uc . "_"
            . $name . " :="
            . join(
            "",
            map { " $_" } @{
                $self->_filename_lists_post_filter->(
                    {
                        filenames => $bucket->{'results'},
                        bucket    => $name,
                        host      => $id,
                    }
                )
            }
            ) . "\n";
    }

    if ( $id ne "common" )
    {
        my $rules = $self->get_rules_template($host);

        $rules =~ s!X8X!$host_uc!g;
        $rules =~ s!x8x!$id!ge;
        $rules_text .= $rules;
    }

    return {
        'file_lists' => $file_lists_text,
        'rules'      => $rules_text,
    };
}

1;

__END__