File Coverage

blib/lib/Module/Cooker.pm

Criterion	Covered	Total	%
statement	209	222	94.1
branch	63	90	70.0
condition	6	9	66.6
subroutine	38	43	88.3
pod	11	11	100.0
total	327	375	87.2

package Module::Cooker;

our $VERSION = 'v0.1_6';

#use 5.008_008;

use strict;
use warnings FATAL => 'all';

use Data::Dumper;

use Carp;
use Cwd ();
use Try::Tiny;

use version 0.77;

use ExtUtils::Manifest qw( mkmanifest );
use Storable (qw( dclone ));

use File::Path 2.07 qw( make_path );
use File::Spec::Functions qw( catdir catfile );
use File::Which;

use POSIX qw( strftime );

use Template;

my $profile_name_rx = qr/[A-Z_a-z][A-Z_a-z0-9.-]*/;

# the following regex is ripped from Module::Runtime
# suggested by Perl Monk tobyink (http://www.perlmonks.org/?node_id=757127)
my $module_name_rx = qr/[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/;

my $defaults = {
    minperl   => '',
    author    => 'A. Uthor',
    email     => '[e-mail]',
    profile   => 'default',
    package   => 'My::MC::Module',
    version   => 'v0.1_1',
    extravars => {},
    localdirs => [],
    nosubs    => 0,

#    nolinks => 1, # future use?
};

my @boolean_params = (
    'nosubs',

#    'nolinks', # future use?
);

sub new {
    my $class    = shift;
    my %incoming = @_;

    my $self = bless _validate_incoming( \%incoming ), $class;

    # be lazy and automatically generate accessors.
    # Perl Monk GrandFather should appreciate this. :)
    foreach my $attribute ( keys( %{$self} ) ) {
        next if $attribute =~ /^_/;
        next if $self->can($attribute);

        no strict 'refs';

        # auto-generated accessors should go in this package, not a
        # sub-class. the sub-class can always override like
        # normal if need be.
        *{ __PACKAGE__ . "::$attribute" } = sub {
            my $self = shift;

            croak "Can't set read-only attribute: $attribute" if @_;

            return $self->{$attribute};
        };
    }

    # this needs to be set at the time of instance creation because
    # if a subsequent chdir occurs the method won't be able to
    # resolve a relative path in %INC. this is specifically needed
    # for the test suite to work properly in a tmp dir.
    $self->{_basename_dir} = $self->_basename_dir;

    $self->{_made_dist_dir} = 0;
    $self->{_templates}     = {};
    $self->{_template_dirs} = [];

    return $self;
}

# NOTE: email addresses are not validated since it might be desirable to
# use an anti-SPAM pattern. i.e. "author at example dot com". suggestions
# as to how to add some form of minimal checking are welcome.
sub _validate_incoming {
    my $incoming = shift;

    my $args = {};
    for ( keys( %{$defaults} ) ) {
        $args->{$_} = delete( $incoming->{$_} ) || $defaults->{$_};
    }
    croak 'Unknown parameter(s): ' . join( ', ', keys( %{$incoming} ) )
      if keys( %{$incoming} );

    croak "Parameter 'package' must be supplied"
      unless $args->{package};
    croak "Invalid package name: $args->{package}"
      unless $args->{package} =~ /\A$module_name_rx\z/o;

    croak "Illegal profile name: $args->{profile}"
      unless $args->{profile} =~ /\A$profile_name_rx\z/o;

    # ensure that boolean params have boolean values
    for (@boolean_params) {
        my $orig = $args->{$_};
        $args->{$_} = !!$args->{$_} || 0;
        croak "Boolean param $_ must be '0' or '1': $orig ne $args->{$_}"
          unless $args->{$_} eq $orig;
    }

    try {
        version->parse( $args->{version} );
    }
    catch {
        croak $_;
    };

    croak "Param 'extravars' must be a hashref"
      unless ( ref( $args->{extravars} ) || '' ) eq 'HASH';

    croak "Param 'localdirs' must be an arrayref"
      unless ( ref( $args->{localdirs} ) || '' ) eq 'ARRAY';

    return $args;
}

# used to build path to where the main package module will be placed
# in the distribution dir.
sub _lib_path {
    my $self = shift;

    my @parts = split( /::/, $self->{package} );
    pop(@parts);    # remove basename

    unshift( @parts, 'lib' );

    return join( '/', @parts );
}

# used to find the location of THIS module. assumes that all support
# dirs will be under a directory named after this module (without
# the '.pm')
# NOTE! this is a class method that doesn't check the 'cached' value.
# YOU WILL BE SURPRISED if there has been an intervening chdir operation!
# see the public 'basename_dir' method for normal use.
sub _basename_dir {
    my $package = __PACKAGE__;

    $package =~ s/::/\//g;
    my $packpath = $INC{ join( '.', $package, 'pm' ) };
    $packpath =~ s/\.pm$//;

    my $realpath = Cwd::realpath($packpath);

    return $realpath;
}

# create the dist dir in the cwd
sub _make_dist_dir {
    my $self = shift;

    # croak if a fatal error occurs, better to die here than later
    try {
        make_path( $self->dist_name ) or die $!;
        $self->{_made_dist_dir} = 1;
    }
    catch {
        die "Can not make distribution dir: $_";
    };

    return;
}

# builds a hash that will be passed to Template
sub _package_info {
    my $self = shift;

    my $module_path = catfile( $self->_lib_path, $self->module_name );

    my $package = {
        name       => $self->{package},
        dist_name  => $self->dist_name,
        libpath    => $self->_lib_path,
        module     => $self->module_name,
        modulepath => $module_path,
        version    => $self->{version},
        minperl    => $self->{minperl},
        timestamp  => strftime( '%Y-%m-%d %T', localtime() ),
        year       => strftime( '%Y', localtime() ),
    };

    return $package;
}

# builds a hash that will be passed to Template
sub _author_info {
    my $self = shift;

    my $author = {
        name  => $self->{author},
        email => $self->{email},
    };

    return $author;
}

sub _include_path {
    my $self = shift;

    return $self->{_include_path} if $self->{_include_path};
}

sub _process_template {
    my $self = shift;
    my %args = @_;

    # Template will automatically create missing dirs, but doing this
    # allows for bailing out if the main dist dir already exists.
    # having the test here ensures catching such a condition at a
    # common point that is less likely to be skipped over.
    if ( !$self->{_made_dist_dir} ) {
        my $direxists = !!( -d $self->dist_name );
        die "Distribution directory already exists: " . $self->dist_name
          if -d $self->dist_name;

        # dist dir does not exist. this also sets _made_dist_dir
        $self->_make_dist_dir;
    }

    die "Template name missing!" unless $args{template};

    my $outfile;
    if ( $args{template} =~ /^Module\.pm$/ ) {    # gets speical treatment
        $outfile = catfile( $self->_lib_path, $self->module_name );
    } else {
        $outfile = $args{template};
    }

# need to add logic to add paths for INCLUDE directives to INCLIDE_PATH

    # this is a seperate stucture to all for a future method to let
    # users specify additional config options similar to how
    # extravars work.
    my $tt_config = {
        TRIM         => 0,
        PRE_CHOMP    => 0,
        POST_CHOMP   => 0,
        INCLUDE_PATH => \@{ $self->profile_dirs },
        OUTPUT_PATH  => $self->dist_name,
    };
    my $t = Template->new($tt_config);

    my $vars = $self->template_data;

    $t->process( $args{template}, $vars, $outfile ) || die $t->error . "\n";

    return;
}

sub _gather_profile {
    my $self = shift;
    my %args = @_;

    my $dir    = $args{abs_path};
    my $subdir = $args{subdir_path};

    die "Can't find dir: $dir\n" unless -d $dir;

    opendir( my $dh, $dir ) or die "can't opendir $dir: $!";
    my @files = readdir($dh);
    closedir $dh;

    my $std_dir = $self->std_profiles_dir;
    my $src_type = ( $dir =~ /^(?:\Q$std_dir\E)/ ) ? 'standard' : 'local';

    for my $fname (@files) {
        next if $fname =~ m{^\.{1,2}\z};

        my $fpath = File::Spec->catfile( $dir, $fname );

        # $fpath = readlink($fpath) if -l $fpath;

        # don't follow symlinks for now.
        # use nolinks param to control this later if desired.
        next if -l $fpath;

        if ( -d $fpath ) {
            if ( $self->{nosubs} ) {
                warn "Skipping profile sub-directory: $fpath\n";
                next;
            }

            my $subpath = $subdir ? catdir( $subdir, $fname ) : $fname;

            try {
                push( @{ $self->{_template_dirs} }, $subpath );

                # trust perl's deep recursion detection
                $self->_gather_profile(
                    abs_path    => $fpath,
                    subdir_path => $subpath
                );
            }
            catch {
                die $_;
            };

            next;
        }

        next unless -f $fpath;

        my $template = $subdir ? catfile( $subdir, $fname ) : $fname;
#        $self->{_templates}{$template} = catfile( $dir, $subdir )
        $self->{_templates}{$template} = $src_type
          unless $self->{_templates}{$template};
    }

    return;
}

# future use? considering an option to pass Template through perltidy
sub _perltidy_cmd {
    my $tidy = which('perltidy');

    return $tidy;
}

# override the default accessor generation to ensure a copy is made
sub extravars {
    my $self = shift;

    croak "Can't set read-only attribute: extravars" if @_;

    my $tmp       = $self->{extravars};
    my $extravars = dclone($tmp);

    return wantarray ? %{$extravars} : $extravars;
}

# override the default accessor generation to ensure a copy is made
sub localdirs {
    my $self = shift;

    croak "Can't set read-only attribute: localdirs" if @_;

    my @localdirs = @{ $self->{localdirs} };

    return wantarray ? @localdirs : \@localdirs;
}

# return a list of dirs that actually contain the requested profile
sub profile_dirs {
    my $self = shift;

    croak "Can't set read-only method: profile_dirs" if @_;

    my @searchdirs = $self->localdirs;
    push( @searchdirs, catdir( $self->std_profiles_dir ) );

    my @profile_dirs;
    for (@searchdirs) {
        my $profile_dir = catdir( $_, $self->profile );
        push( @profile_dirs, $profile_dir ) if -d $profile_dir;
    }

    return wantarray ? @profile_dirs : \@profile_dirs;
}

sub basename_dir {
    my $self = shift;

    croak "Can't set read-only method: basename_dir" if @_;

    return $self->{_basename_dir};
}

# builds path to where standard templates located
sub std_profiles_dir {
    my $self = shift;

#    my $dir = catdir( $self->basename_dir, 'profiles', $self->{profile} );
    my $dir = catdir( $self->basename_dir, 'profiles' );

    -d $dir ? return $dir : return;
}

# builds list of final attribute values
sub summary {
    my $self = shift;

    croak "Can't set read-only method: summary" if @_;

    my $tmp = {};
    for ( keys( %{$self} ) ) {
        next if /^_/;    # we only want the attributes, not internals
        $tmp->{$_} = $self->{$_};
    }

    my $summary = dclone($tmp);

    # sorry, Will, but i think this is handy. :)
    return wantarray ? %{$summary} : $summary;
}

# simple transform: i.e. Foo::Bar -> Foo-Bar
sub dist_name {
    my $self = shift;

    croak "Can't set read-only method: dist_name" if @_;

    my $dname = $self->{package};
    $dname =~ s/::/-/g;

    return $dname;
}

# generates main module name. i.e. Foo::Bar -> Bar.pm
sub module_name {
    my $self = shift;

    croak "Can't set read-only method: module_name" if @_;

    my @parts = split( /::/, $self->{package} );

    return join( '.', pop(@parts), 'pm' );
}

sub template_data {
    my $self = shift;

    croak "Can't set read-only method: template_data" if @_;

    my $tmp = {
        author    => $self->_author_info,
        package   => $self->_package_info,
        modcooker => {
            version => $VERSION,
            perlver => $],
        },
        extra => $self->{extravars},
    };

    my $tdata = dclone($tmp);

    return wantarray ? %{$tdata} : $tdata;
}

# the ultimate goal of this module
sub cook {
    my $self = shift;

    # clear our template list
    $self->{_templates}     = {};
    $self->{_template_dirs} = [];

    for ( @{ $self->profile_dirs } ) {
        my $dir = Cwd::realpath($_);
        $self->_gather_profile( abs_path => $dir, subdir_path => undef );
    }

#warn Dumper($self->{_templates});
    foreach ( keys( %{ $self->{_templates} } ) ) {
        $self->_process_template( template => $_ );
    }

    if ( !-f catfile( $self->dist_name, 'MANIFEST' ) ) {
        chdir $self->dist_name;
        mkmanifest();
        chdir '..';
    }

}

1;    # End of Module::Cooker
__END__