File Coverage

lib/Su/Process.pm

Criterion	Covered	Total	%
statement	128	140	91.4
branch	46	68	67.6
condition	9	12	75.0
subroutine	19	21	90.4
pod	6	6	100.0
total	208	247	84.2

package Su::Process;

use strict;
use warnings;
use Exporter;
use File::Path;
use Data::Dumper;
use Test::More;
use Carp;
use Fatal qw(open close);

use Su::Template;
use Su::Log;

our @ISA = qw(Exporter);

our @EXPORT = qw(comp gen generate_proc generate_process);

our $DEBUG = 0;

# not used
my $MODULE_PATH = __FILE__;

our $PROCESS_BASE_DIR = "./";

our $PROCESS_DIR = "Procs";

=pod

=head1 NAME

Su::Process - A module to generate and execute user process.

=head1 SYNOPSIS

use Su::Process;

# Generate the Process file.

 generate_proc('pkg/SomeProc');

# Execute the Process and get it's result.

 $ret = gen("pkg/SomeProc");
 $ret = comp("pkg/SomeProc");

=head1 DESCRIPTION

Su::Process has a method to generate the template of the Process
module to describe user process.  These Processes are called from the
method Su::resolve.  The user Processes are also called directry by
the method L. The method
L is an alias of the method
L for embed to the template like a component.

=head1 ATTRIBUTES

=head2 C<$SUPRESS_LOAD_ERROR>

For suppress the load error because of the specified module file is not found.

 $Su::Process::SUPPRESS_LOAD_ERROR = 1;

=cut

our $SUPPRESS_LOAD_ERROR = 0;

=head1 FUNCTIONS

=over

=cut

=item new()

A Constructor.

=cut

sub new {
  my $self = shift;

  my %h = @_ if @_;
  my $log = Su::Log->new;
  $h{logger} = $log;
  return bless \%h, $self;
} ## end sub new

sub import {
  my $self = shift;

  # Save import list and remove from hash.
  my %tmp_h        = @_;
  my $imports_aref = $tmp_h{import};
  delete $tmp_h{import};
  my $base = $tmp_h{base};
  my $dir  = $tmp_h{dir};
  Su::Log->trace( "base:" . Dumper($base) );
  Su::Log->trace( "dir:" . Dumper($dir) );

  #  print "base:" . Dumper($base) . "\n";
  #  print "dir:" . Dumper($dir) . "\n";

  $PROCESS_BASE_DIR = $base if $base;
  $PROCESS_DIR      = $dir  if $dir;

  if ( $base || $dir ) {
    $self->export_to_level( 1, $self, @{$imports_aref} );
  } else {

# If 'base' or 'dir' is not passed, then all of the parameters are required method names.
    $self->export_to_level( 1, $self, @_ );
  }

} ## end sub import

=item generate_process()

This function is just a synonym of the method L.

=cut

sub generate_process {

  my $self = shift if ( ref $_[0] eq __PACKAGE__ );
  if ($self) {
    $self->generate_proc(@_);
  } else {
    generate_proc(@_);
  }
} ## end sub generate_process

=item generate_proc()

Generate the Process file to describe your own code in the method 'process'.
This method can be used from the command line like the following.

 perl -MSu::Process -e '{generate_proc("MainProc")}'

If generation is success, this subroutine return the generated file
name, else should die or return undef.

=cut

sub generate_proc {
  my $self = shift if ( ref $_[0] eq __PACKAGE__ );
  my $PROCESS_BASE_DIR = $self->{base} ? $self->{base} : $PROCESS_BASE_DIR;
  my $PROCESS_DIR      = $self->{dir}  ? $self->{dir}  : $PROCESS_DIR;

  my ( $comp_id, $gen_type ) = @_;

  # Make directory path.
  my @arr = split( '/|::', $comp_id );
  my $comp_base_name = '';
  if ( scalar @arr > 1 ) {
    $comp_base_name = join( '/', @arr[ 0 .. scalar @arr - 2 ] );
  }

  my $dir;

# If class name is specified with package, then not use $PROCESS_DIR as a part of output path.
  if ( $comp_id =~ /::/ ) {
    $dir = $PROCESS_BASE_DIR . "/" . $comp_base_name;
  } else {
    $dir = $PROCESS_BASE_DIR . "/" . $PROCESS_DIR . "/" . $comp_base_name;
  }

  # Prepare directory for generate file.
  mkpath $dir unless ( -d $dir );

  # '$!' can't judge error correctly.
  #  $! and die "$!:" . $dir;
  if ( !-d $dir ) {
    die "Can't make dir:" . $!;
  }

  # Generate file.
  my $comp_id_filepath = $comp_id;
  $comp_id_filepath =~ s!::!/!g;
  my $fpath;

# If package name is specified with class name, then not use $PROCESS_DIR as output file path.
  if ( $comp_id =~ /::/ ) {
    $fpath = $PROCESS_BASE_DIR . "/" . $comp_id_filepath . ".pm";
  } else {
    $fpath =
      $PROCESS_BASE_DIR . "/" . $PROCESS_DIR . "/" . $comp_id_filepath . ".pm";
  }
  open( my $file, '>', $fpath );

  # Get the function contents.
  $comp_id =~ s/\//::/g;
  my $fun = '_template_' . ( $gen_type ? $gen_type : 'default' );
  my $contents = '';
  $contents = eval( "return " . $fun . "(\"$comp_id\");" );
  $@ and die $@;

  my $ret = print $file $contents;
  if ( $ret == 1 ) {
    print "generated:$fpath\n";
    return $fpath;
  } else {
    print "output fail:$fpath\n";
    return undef;
  }

} ## end sub generate_proc

=begin comment

Return the contents of a new Process which uses Su template.
This method is called by gen_proc via dinamic method call.

=end comment

=cut

sub _template_default {
  my $self = shift if ( ref $_[0] eq __PACKAGE__ );

  my $comp_id = shift;
  my $ret = expand( << '__HERE__', $comp_id );
% my $comp_id = shift;
package <%=$comp_id%>;
use strict;
use warnings;
use Su::Template;

my $model={};

sub new {
  return bless { model => $model }, shift;
}

# The main method for this process class.
sub process{
  my $self = shift if ($_[0] && ref $_[0] eq __PACKAGE__);
  my $self_module_name = shift if ($_[0] && $_[0] eq __PACKAGE__);
  my $model = keys %{ $self->{model} } ? $self->{model} : $model;

  my $param = shift;
#$Su::Template::DEBUG=1;
  my $ret = expand(<<'__TMPL__');

__TMPL__
#$Su::Template::DEBUG=0;
  return $ret;
}

# This method is called if specified as a map filter class.
sub map_filter{
  my $self = shift if ref $_[0] eq __PACKAGE__;
  my @results = @_;

  for ( @results ){

  }

  return @results;
}

# This method is called if specified as a reduce filter class.
sub reduce_filter{
  my $self = shift if ref $_[0] eq __PACKAGE__;
  my @results = @_;
  my $result;
  for ( @results ){

  }

  return $result;
}

# This method is called if specified as a scalar filter class.
sub scalar_filter{
  my $self = shift if ref $_[0] eq __PACKAGE__;
  my $result = shift;


  return $result;
}

sub model{
  my $self = shift if ref $_[0] eq __PACKAGE__;
  my $self_module_name = shift if $_[0] eq __PACKAGE__;
  my $arg = shift;
  if ($arg) {
    if ($self) { $self->{model} = $arg; }
    else {
      $model = $arg;
    }
  } else {
    if ($self) {
      return $self->{model};
    } else {
      return $model;
    }
  } ## end else [ if ($arg) ]
}

1;
__HERE__

  return $ret;
} ## end sub _template_default

=begin comment

Return the contents of a new Process which uses Mojo template.
This method is called by gen_proc via dinamic method call.

=end comment

=cut

sub _template_mojo {
  my $self = shift if ( ref $_[0] eq __PACKAGE__ );

  my $comp_id = shift;
  my $header  = "package $comp_id;";
  my $ret     = << '__HERE__';
use Mojo::Template;
use strict;
use warnings;

my $model = {};

sub process{
  if($_[0] eq __PACKAGE__){
    shift;
  }

  my $ctx_hash_ref = shift;
  my $mt = Mojo::Template->new;
  my $ret = $mt->render(<<'__TMPL__',$ctx_hash_ref);
% my $ctx_href = shift;


__TMPL__

  return $ret;
}

sub model{
  if($_[0] eq __PACKAGE__){
    shift;
  }
  my $arg = shift;
  if ($arg){
    $model = $arg;
  }else{
    return $model;
  }
}

1;
__HERE__

  return $header . "\n" . $ret;

} ## end sub _template_mojo

=item comp()

This method is just a alias of L metnod.

=cut

sub comp {
  return gen(@_);
}

=item gen()

 my $ret = gen('process_id');
 my $ret = gen('dir/process_id');
 my $ret = gen('dir::process_id');

Return the result of the process which coressponds to the passed
process id.
The process id is a qualified module name.
Note that the specified process is simply called it's C
method and can't access to it's model field.

=cut

sub gen {
  my $self = shift if ( ref $_[0] eq __PACKAGE__ );
  my $PROCESS_BASE_DIR = $self->{base} ? $self->{base} : $PROCESS_BASE_DIR;
  my $PROCESS_DIR      = $self->{dir}  ? $self->{dir}  : $PROCESS_DIR;

  my $comp_id = shift;
  my @ctx     = @_;

  my $f      = $PROCESS_BASE_DIR . "/" . $PROCESS_DIR . "/" . $comp_id;
  my $suffix = _has_suffix($f);

  # If passed file has suffix, return file contents itself.
  if ( -f $f && $suffix and $suffix ne '.pm' ) {
    return _read_contents($f);
  }

  my $proc        = Su::Process->new;
  my $proc_module = $proc->load_module($comp_id);

  return $proc_module->process(@ctx);

} ## end sub gen

=item load_module()

 my $su_proc = Su::Process->new;
 my $proc_module = $su_proc->load_module($module_name);

=cut

sub load_module {
  my $self = shift if ( ref $_[0] eq __PACKAGE__ );
  my $PROCESS_BASE_DIR = $self->{base} ? $self->{base} : $PROCESS_BASE_DIR;
  my $PROCESS_DIR      = $self->{dir}  ? $self->{dir}  : $PROCESS_DIR;
  my $comp_id          = shift;
  my @ctx = @_ if @_;

  my $f = $comp_id;
  $f =~ s!::!/!g;
  $f .= ".pm";

  # Trim the head of dot slash(./) of the file path.
  $f =~ s!^\./(.+)!$1!;

  # Replace directory separator to package separator.
  $comp_id =~ s/\//::/g;

  # If $comp_id is a package which described in some module file whose
  # filename is not match $comp_id, then we can't load package
  # '$comp_id' from filename using require.  In such case, we hope
  # package may be already loaded, so we don't load and just return the
  # package id.
  eval { require $f; };

  # Note if $SUPRESS_LOAD_ERROR is set, don't throw error.
  croak $@ if $@ and !$SUPPRESS_LOAD_ERROR;

  my $ret;

  # TODO: Add mode to re-use instance.
  if ( exists &{ ( $comp_id . "::new" ) } ) {
    $ret = $comp_id->new;
  } else {
    $ret = $comp_id;
  }

  #  require $comp_id if $@;
  return $ret;

} ## end sub load_module

=begin comment

Read the contents of the passed file.

=end comment

=cut

sub _read_contents {
  my $self = shift if ( ref $_[0] eq __PACKAGE__ );

  my $path = shift;
  my $fh   = undef;
  open $fh, '<', $path or die "Can't open file:$!";
  my $ret = join '', <$fh>;
  close $fh;
  return $ret;
} ## end sub _read_contents

=begin comment

Return the suffix string if the passed string has some suffix.
If the passed string has not any suffix, then return undef.

=end comment

=cut

sub _has_suffix {
  my $self = shift if ( ref $_[0] eq __PACKAGE__ );

  my $path = shift;
  my @pass_elem = split( '/', $path );
  $path = @pass_elem[ scalar @pass_elem - 1 ] if scalar @pass_elem > 1;
  my $ridx = rindex( $path, '.' );
  return ( $ridx == -1 ? undef : substr( $path, $ridx ) );
} ## end sub _has_suffix

=pod

=back

=cut

1;