File Coverage

lib/Module/New/Context.pm

Criterion	Covered	Total	%
statement	82	91	90.1
branch	16	22	72.7
condition	5	13	38.4
subroutine	19	22	86.3
pod	12	12	100.0
total	134	160	83.7

package Module::New::Context;

use strict;
use warnings;
use Carp;

use Module::New::Loader;
use Module::New::Log;
use Sub::Install 'reinstall_sub';
use Time::Piece;

foreach my $accessor (qw( template date path loader files )) {
  reinstall_sub({
    as   => $accessor,
    code => sub { shift->{$accessor} },
  });
}

sub new {
  my $class = shift;

  my $loader = Module::New::Loader->new(@_);
  my $self = bless { loader => $loader }, $class;

  foreach my $name (qw( License Template )) {
    $self->{lc $name} = $loader->load_class($name);
  }

  foreach my $name (qw( Config Path Files )) {
    $self->{lc $name} = $loader->load($name);
  }

  $self->{date} = Time::Piece->new;

  $self;
}

sub config {
  my $self = shift;
  return $self->{config} unless @_;
  return $self->{config}->get(@_) if @_ == 1;
  $self->{config}->set(@_);
}

sub license {
  my ($self, $type, $args) = @_;
  $type ||= $self->config('license') || 'perl';
  $args ||= {};
  $args->{holder} ||= $self->config('author');
  $args->{year} ||= $self->date->year;
  $self->{license}->object( $type, $args );
}

sub distname {
  my $self = shift;

  if ( @_ ) {
    my $module = my $dist = shift;
    $dist   =~ s/::/\-/g;
    $module =~ s/\-/::/g;

    croak "$dist looks weird" if $dist =~ tr/A-Za-z0-9_\-//cd;

    my $distid = lc $dist;
       $distid =~ s/\-/_/g;

    $self->{distname} = $dist;
    $self->{distid}   = $distid;
    $self->module( $module );
  }

  $self->{distname};
}

sub module {
  my $self = shift;

  if ( @_ ) {
    $self->{module} = shift;
    my $path = $self->{module};
       $path =~ s|::|\/|g;
    my $id   = lc $path;
       $id   =~ s|/|_|g;
    $self->mainfile("lib/$path.pm");
    $self->modulepath($path);
    $self->moduleid($id);
  }
  $self->{module};
}

sub mainfile {
  my $self = shift;
  if ( @_ ) {
    $self->{mainfile} = shift;
  }
  $self->{mainfile};
}

sub maindir {
  my $self = shift;
  my $dir = $self->{mainfile};
     $dir =~ s/\.pm$//;
  return $dir;
}

sub modulepath {
  my $self = shift;
  if ( @_ ) {
    $self->{modulepath} = shift;
  }
  $self->{modulepath};
}

sub moduleid {
  my $self = shift;
  if ( @_ ) {
    $self->{moduleid} = shift;
  }
  $self->{moduleid};
}

sub modulebase {
  my $self = shift;
  my ($name) = $self->{module} =~ /(\w+)$/;
  return $name;
}

sub distid {
  my $self = shift;
  if ( @_ ) {
    $self->{distid} = shift;
  }
  $self->{distid};
}

sub repository {
  my $self = shift;
  if ( @_ ) {
    $self->{repository} = shift;
  }
  $self->{repository} || '';
}

*dist_name   = \&distname;
*dist_id     = \&distid;
*main_file   = \&mainfile;
*main_dir    = \&maindir;
*module_path = \&modulepath;
*module_id   = \&moduleid;
*module_base = \&modulebase;

1;

__END__