File Coverage

blib/lib/PAB3.pm

Criterion	Covered	Total	%
statement	55	331	16.6
branch	5	152	3.2
condition	3	77	3.9
subroutine	15	28	53.5
pod	8	12	66.6
total	86	600	14.3

package PAB3;
# =============================================================================
# Perl Application Builder
# Module: PAB3
# Use "perldoc PAB3" for documentation
# =============================================================================
use Carp ();
use Symbol ();

use strict;
no strict 'refs';
use warnings;
no warnings 'uninitialized';

use vars qw($VERSION %SC $_CURRENT);

use constant {
	SCALAR			=> 1,
	ARRAY			=> 2,
	HASH			=> 3,
	FUNC			=> 4,
};

BEGIN {
	$VERSION = '3.201';
	require XSLoader;
	XSLoader::load( __PACKAGE__, $VERSION );
	if( ! $PAB3::CGI::VERSION ) {
		$SIG{'__DIE__'} = \&_die_handler;
		$SIG{'__WARN__'} = \&_warn_handler;
	}
	*print_r = \&print_var;
}

END {
	&_cleanup();
}

1;

sub import {
	my $pkg = shift;
	my $callpkg = caller();
	if( $_[0] and $pkg eq __PACKAGE__ and $_[0] eq 'import' ) {
		*{$callpkg . '::import'} = \&import;
		return;
	}
	foreach( @_ ) {
		if( $_ eq ':const' || $_ eq ':default' ) {
			*{$callpkg . '::PAB_SCALAR'} = \&{$pkg . '::SCALAR'};
			*{$callpkg . '::PAB_ARRAY'} = \&{$pkg . '::ARRAY'};
			*{$callpkg . '::PAB_HASH'} = \&{$pkg . '::HASH'};
			*{$callpkg . '::PAB_FUNC'} = \&{$pkg . '::FUNC'};
		}
		if( $_ eq ':default' ) {
			*{$callpkg . '::print_var'} = \&{$pkg . '::print_var'};
			*{$callpkg . '::print_r'} = \&{$pkg . '::print_var'};
			*{$callpkg . '::require'} = \&{$pkg . '::require'};
			*{$callpkg . '::require_and_run'} = \&{$pkg . '::require_and_run'};
		}
	}
}

sub setenv {
	if( $0 =~ /^(.+\/)(.+?)$/ ) {
		$ENV{'SCRIPT_PATH'} = $1;
		$ENV{'SCRIPT'} = $2;
	}
	else {
		$ENV{'SCRIPT_PATH'} = '';
		$ENV{'SCRIPT'} = $0;
	}
}

sub new {
	my $proto = shift;
	my $class = ref( $proto ) || $proto;
	my $this = &_new( $class, @_ ) or return undef;
	my %arg = @_;
	$this->{'die'} = defined $arg{'die'} ? $arg{'die'} : 1;
	$this->{'warn'} = defined $arg{'warn'} ? $arg{'warn'} : 1;
	$this->{'path_template'} = $arg{'path_template'};
	$this->{'path_cache'} = $arg{'path_cache'};
	$this->{'auto_cache'} = $arg{'auto_cache'};
	$this->{'hashmap_cache'} = $arg{'hashmap_cache'};
	$this->{'logger'} = $arg{'logger'};
	return $this;
}

sub handle_error {
	my( $this ) = @_;
	if( $this ) {
		&Carp::croak( &error( $this ) ) if $this->{'die'};
		&Carp::carp( &error( $this ) ) if $this->{'warn'};
	}
	return 0;
}

sub parse_template {
	&_parse_template( @_ ) or return handle_error( @_ );
}

sub make_script_and_run {
	my( $this, $template, $cache, $package ) = @_;
	my( @ts, @cs, $rv, $ct, $cac, $tpl, $fh );
	$_CURRENT = $this;
	$package ||= ( CORE::caller )[0];
	$tpl = $this->{'path_template'} . $template;
	if( ! $cache && $this->{'auto_cache'} ) {
		$cache = '_auto.' . $template . '.pl';
		$cache =~ tr!/!.!;
		$cache =~ tr!\\!.!;
	}
	if( $cache ) {
		$cac = $this->{'path_cache'} . $cache;
		if( -f $tpl ) {
			@ts = stat( $tpl );
			if( -f $cac ) {
				@cs = stat( $cac );
				if( $ts[9] == $cs[9] ) {
					&require_and_run( $this, $cac, $package );
					return 1;
				}
			}
		}
	}
	if( $this->{'logger'} ) {
		$this->{'logger'}->debug( "Parse template \"$tpl\"" );
	}
	( $rv, $ct ) = &_make_script( $this, $template, $cache );
	if( $rv == 3 ) {
		if( $this->{'logger'} ) {
			$this->{'logger'}->debug( "Save script at \"$cac\"" );
		}
		open( $fh, '> ' . $cac )
			or do {
				$this->set_error( "Unable to open file '$cac': $!" );
				return $this->handle_error();
			};
		flock( $fh, 2 );
		syswrite( $fh, $ct );
		flock( $fh, 8 );
		close( $fh );
		utime( $ts[9], $ts[9], $cac );
		&require_and_run( $this, $cac, $package );
	}
	elsif( $rv == 1 ) {
		utime $ts[9], $ts[9], $cac;
		&require_and_run( $this, $cac, $package );
	}
	elsif( $rv == 2 ) {
		if( $this->{'logger'} ) {
			$this->{'logger'}->debug( "Compile and run \"$tpl\"" );
		}
		$tpl =~ s/\W/_/go;
		&PAB3::_create_script_cache( \$ct, $tpl, $package );
		my $of = $0;
		*0 = \$template;
		&{"PAB3::SC::${tpl}::handler"}();
		*0 = \$of;
	}
	elsif( ! $rv ) {
		return &handle_error( $this );
	}
	return 1;
}

sub add_hashmap {
	my( $this, $loopid, $record, $fieldmap, $tfm ) = @_;
	my( $fm, $fmc, $hmc );
	if( ref( $fieldmap ) eq 'ARRAY' ) {
		my $ifm = 0;
		$fm = {};
		foreach( @$fieldmap ) {
			$fm->{$_} = $ifm ++;
		}
	}
	elsif( ref( $fieldmap ) eq 'HASH' ) {
		$fm = $fieldmap;
	}
	else {
		&set_error( $this, 'Parameter fieldmap is invalid' );
		return &handle_error( $this );
	}
	if( ( $hmc = $this->{'hashmap_cache'} ) ) {
		$fmc = $hmc->get( $loopid, $record, $fm );
	}
	if( ! %$fm ) {
		if( ! $fmc ) {
			&set_error( $this, 'Hashmap is empty' );
			return &handle_error( $this );
		}
		$fm = $fmc;
	}
	&_add_hashmap( $this, $loopid, $record, $fieldmap )
		or return &handle_error( $this );
	if( $hmc && ! $fmc ) {
		$hmc->set( $loopid, $record, $fm );
	}
	$_[4] = $fm;
	return 1;
}

sub require {
	my $this = shift if ref( $_[0] ) eq __PACKAGE__;
	my( $file, $package, $inject_code, $args ) = @_;
	my( $fid, $cache, $content, $fh, @fs, $logger );
	$package ||= ( caller )[0];
	$fid = $file . '_' . $package;
	$fid =~ s/\W/_/go;
	if( $package eq $fid ) {
		&Carp::croak( 'Script requires itself' );
	}
	@fs = stat( $file );
	$cache = $SC{$fid};
	$logger = $this->{'logger'} if $this && $this->{'logger'};
	if( ! $cache || $cache != $fs[9] ) {
		if( $cache ) {
			if( $logger ) {
				$logger->debug( "Unloading PAB3::SC::${fid}" );
			}
			&Symbol::delete_package( "PAB3::SC::${fid}" );
		}
		if( $logger ) {
			$logger->debug( "Compile \"$file\"" );
		}
		open( $fh, $file ) or &Carp::croak( "Unable to open '$file': $!" );
		flock( $fh, 1 );
		read( $fh, $content, $fs[7] );
		flock( $fh, 8 );
		close( $fh );
		&_create_script_cache( \$content, $fid, $package, $file, $inject_code );
		$SC{$fid} = $fs[9];
		if( $logger ) {
			$logger->debug( "Run PAB3::SC::${fid}::handler" );
		}
		my $of = $0;
		*0 = \$file;
		&{"PAB3::SC::${fid}::handler"}( ref( $args ) eq 'ARRAY' ? @$args : $args );
		*0 = \$of;
		return 1;
	}
	return 1;
}

sub require_and_run {
	my $this = shift if ref( $_[0] ) eq __PACKAGE__;
	my( $file, $package, $inject_code, $args ) = @_;
	my( $fid, $cache, $content, $fh, @fs, $of, $logger );
	$package ||= ( caller )[0];
	$fid = $file . '_' . $package;
	$fid =~ s/\W/_/go;
	if( $package eq $fid ) {
		&Carp::croak( 'Script requires itself' );
	}
	@fs = stat( $file );
	$cache = $SC{$fid};
	$logger = $this->{'logger'} if $this && $this->{'logger'};
	if( ! $cache || $cache != $fs[9] ) {
		if( $cache ) {
			if( $logger ) {
				$logger->debug( "Unloading PAB3::SC::${fid}" );
			}
			&Symbol::delete_package( "PAB3::SC::${fid}" );
		}
		if( $logger ) {
			$logger->debug( "Compile \"$file\"" );
		}
		open( $fh, $file ) or &Carp::croak( "Unable to open '$file': $!" );
		flock( $fh, 1 );
		read( $fh, $content, $fs[7] );
		flock( $fh, 8 );
		close( $fh );
		&_create_script_cache( \$content, $fid, $package, $file, $inject_code );
		$SC{$fid} = $fs[9];
	}
	if( $logger ) {
		$logger->debug( "Run PAB3::SC::${fid}::handler" );
	}
	$of = $0;
	*0 = \$file;
	&{"PAB3::SC::${fid}::handler"}( ref( $args ) eq 'ARRAY' ? @$args : $args );
	*0 = \$of;
	return 1;
}

sub _create_script_cache {
	my( $content, $pkg_require, $pkg_caller, $filename, $inject_code ) = @_;
	my( $hr, $data, $end );
	if( ref( $content ) ) {
		$content = $$content;
	}
	$content =~ s!\r!!gso;
	if( $content =~ s/(\n__DATA__\n.*$)//s ) {
		$data = $1;
	}
	else {
		$data = '';
	}
	if( $content =~ s/(\n__END__\n.*$)//s ) {
		$end = $1;
	}
	else {
		$end = '';
	}
	$filename ||= $0;
	$inject_code ||= '';
	$content = <
package PAB3::SC::$pkg_require;
our \$VERSION = 1;
*handler = sub {
package $pkg_caller;
$inject_code
#line 1 $filename
$content
};
1;
$data
$end
EORAR01
	if( $GLOBAL::DEBUG ) {
		$PAB3::CGI::VERSION
			? &PAB3::CGI::print_code( $content, $filename )
			: &PAB3::print_code( $content, $filename )
		;
	}
    {
        no strict;
        no warnings FATAL => 'all';
        local( $SIG{'__DIE__'}, $SIG{'__WARN__'} );
        eval $content;
    }
	if( $@ ) {
		if( ! $GLOBAL::DEBUG ) {
			$PAB3::CGI::VERSION
				? &PAB3::CGI::print_code( $content, $filename )
				: &PAB3::print_code( $content, $filename )
			;
		}
		&Carp::croak( $@ );
	};
}

sub print_code {
	my( $t, $l, $p );
	foreach $t( @_ ) {
		$t =~ s!\r!!gso;
		if( defined $t ) {
			print "\n";
			$p = 1;
			foreach $l( split( /\n/, $t ) ) {
				print $p . "\t" . $l . "\n";
				$p ++;
			}
			print "\n";
		}
	}
}

sub print_hash {
	my( $hashname, $ref_table, $level ) = @_;
	my( $r_hash, $r, $k );
	$ref_table ||= [];
	if( $hashname =~ /HASH\(0x\w+\)/ ) {
		$r_hash = $hashname;
	}
	else {
		return;
	}
	print $r_hash;
	if( $ref_table->{$r_hash} && $ref_table->{$r_hash} <= $level ) {
		print " [recursive loop]\n";
		return;
	}
	print "\n", "    " x $level, "(\n";
	$ref_table->{$r_hash} = $level + 1;
	foreach $k( sort { lc( $a ) cmp lc( $b ) } keys %{ $r_hash } ) {
		print "    " x ( $level + 1 ) . "[$k] => ";
		$r = ref( $r_hash->{$k} );
		if( $r && index( $r_hash->{$k}, 'ARRAY(' ) >= 0 ) {
			&print_array( $r_hash->{$k}, $ref_table, $level + 1 );
		}
		elsif( $r && index( $r_hash->{$k}, 'HASH(' ) >= 0 ) {
			&print_hash( $r_hash->{$k}, $ref_table, $level + 1 );
		}
		else {
			print ( ! defined $r_hash->{$k} ? '(null)' : $r_hash->{ $k } );
			print "\n";
		}
	}
	print "    " x $level, ")\n";
}

sub print_array {
	my( $arrayname, $ref_table, $level ) = @_;
	my( $r_array, $r, $v, $i );
	$ref_table ||= {};
	$level ||= 0;
	if( $arrayname =~ /ARRAY\(0x\w+\)/ ) {
		$r_array = $arrayname;
	}
	else {
		return;
	}
	print $r_array;
	if( $ref_table->{$r_array} && $ref_table->{$r_array} <= $level ) {
		print " [recursive loop]\n";
		return;
	}
	print "\n", "    " x $level, "(\n";
	$ref_table->{$r_array} = $level + 1;
	$i = 0;
	foreach $v( @{ $r_array } ) {
		$r = ref( $v );
		print "    " x ( $level + 1 ) . "[$i] => ";
		if( $r && index( $v, 'ARRAY(' ) >= 0 ) {
			&print_array( $v, $ref_table, $level + 1 );
		}
		elsif( $r && index( $v, 'HASH(' ) >= 0 ) {
			&print_hash( $v, $ref_table, $level + 1 );
		}
		else {
			print "" . ( ! defined $v ? '(null)' : $v ) . "\n";
		}
		$i ++;
	}
	print "    " x $level, ")\n";
}

sub print_var {
	my( $v, $r, $ref_table );
	$ref_table = {};
	foreach $v( @_ ) {
		$r = ref( $v );
		if( $r && index( $v, 'ARRAY(' ) >= 0 ) {
			&print_array( $v, $ref_table, 0 );
		}
		elsif( $r && index( $v, 'HASH(' ) >= 0 ) {
			&print_hash( $v, $ref_table, 0 );
		}
		elsif( $r && index( $v, 'SCALAR(' ) >= 0 ) {
			print defined $$v ? $$v : '(null)', "\n";
		}
		else {
			print defined $v ? $v : '(null)', "\n";
		}
	}
}

sub _die_handler {
	my $str = shift;
	my( @c, $step );
	print "\nFatal: $str\n\n";
	@c = caller();
	print $c[0] . ' raised the exception at ' . $c[1] . ' line ' . $c[2] . "\n";
	$step = 1;
	while( @c = caller( $step ) ) {
		print $c[0] . ' called ' . $c[3] . ' at ' . $c[1] . ' line ' . $c[2] . "\n";
		$step ++;
	}
	print "\n";
	exit( 0 );
}

sub _warn_handler {
	my $str = shift;
	print "\nWarning: $str\n";
}

__END__