File Coverage

blib/lib/Parse/Template.pm

Criterion	Covered	Total	%
statement	55	143	38.4
branch	2	32	6.2
condition	0	18	0.0
subroutine	16	25	64.0
pod	6	7	85.7
total	79	225	35.1

use strict;
use warnings;
require 5.006;
package Parse::Template;
$Parse::Template::VERSION = '3.08';

use Carp;
use constant DEBUG => 0;
use vars qw/$AUTOLOAD/;
sub AUTOLOAD {
  my($class, $part) = ($AUTOLOAD =~ /(.*)::(.*)$/);
  no strict 'refs';
  *$AUTOLOAD = sub { (ref $_[0] || $class)->eval("$part", @_) };
  goto &$AUTOLOAD;
}

use Symbol qw(delete_package);
{ my $id = 0; sub getid { $id++ } }

my $PACKAGE = __PACKAGE__;
sub new {
  my $receiver = shift;
  my $class = $PACKAGE . '::Sym' . getid();
  my $self = bless {}, $class;	# absolutely nothing in $self
  no strict 'refs';
  %{"${class}::template"} = ();	# so no 'used only once' warning
  ${"${class}::ancestor"} = '';	# so no 'used only once' warning

  @{"${class}::ISA"} = ref $receiver || $receiver;
  ${"${class}::ancestor"} = $receiver;	# reverse the destruction order
  *{"${class}::AUTOLOAD"} = \&AUTOLOAD; # so no warning for procedural calls
  %{"${class}::template"} = @_ ;
  $self;
}
use constant TRACE_ENV => 0;
sub env {
  my $self = shift;
  my $class = ref $self || $self;
  my $symbol = shift;
  if ($symbol =~ /\W/) {
    Carp::croak "invalid symbol name: $symbol"
  }
  no strict;
  if (@_) {
    do {
      my $value = shift;
      print STDERR "${class}::$symbol\t$value\n" if TRACE_ENV;
      if (ref $value) {
		*{"${class}::$symbol"} = $value;
      } else {			# scalar value
      	*{"${class}::$symbol"} = \$value;
      }
      $symbol = shift if @_;
      if ($symbol =~ /\W/) {
		Carp::croak "invalid symbol name: $symbol";
      }
    } while (@_);
  }
  elsif (defined *{"${class}::$symbol"}) { # borrowed from Exporter.pm
    return \&{"${class}::$symbol"} unless $symbol =~ s/^(\W)//;
    my $type = $1;
    return
		$type eq '*' ?  *{"${class}::$symbol"} :
		$type eq "\$" ? \${"${class}::$symbol"} :
		$type eq '%' ? \%{"${class}::$symbol"} :
		$type eq '@' ? \@{"${class}::$symbol"} :
		$type eq '&' ? \&{"${class}::$symbol"} :
		do { Carp::croak("Can\'t find symbol: $type$symbol") };
  }
  else {
    undef;
  }
}
sub DESTROY {
  print STDERR "destroy(@_): ", ref $_[0], "\n" if DEBUG;
  delete_package(ref $_[0]);
}
# Purpose: validate the regexp and replace "!" by "\!", and "/" by "\/"
#          if not already escaped
# Arguments: a regexp
# Returns: the preprocessed regexp
sub ppregexp {
  #  my $self = $_[0]; # useless
  my $regexp = $_[1];
  eval { '' =~ /$regexp/ };
  if ($@) {
    $@ =~ s/\s+at\s+[^\s]+\s+line\s+\d+[.]\n$//; # annoying info
    Carp::croak $@;
  }
  for ($regexp) {
	s{
		( (?: \G | [^\\] ) (?: \\{2} )* )		# even number of back-slashes
		( [!/\"] )								# used delimiters
	}{$1\\$2}xg;

	# replace back exceptions (?!...), (?
	s{
		( \( \?
		\\										# inserted by first replace
		( ! )									# delimiter
	}{$1$2}xg;									# remove back-slash
  }
  $regexp;
}
sub getPart {
  my $self = shift;
  my $part = shift;
  my $class = ref $self || $self;
  my $text = '';
  no strict 'refs';
  unless (defined($text = ${"${class}::template"}{$part})) {
     my $parent = ${"${class}::ISA"}[0]; # delegation
     unless (defined $parent) {
      Carp::croak("'$part' template part is not defined");
    }
    $text = $parent->getPart($part);
  }
  $text;
}
sub setPart {
  my $self = shift;
  my $part = shift;
  my $class = ref $self || $self;
  no strict 'refs';
  ${"${class}::template"}{$part} = shift;
}
$Parse::Template::CONFESS = 1;
my $Already_shown = 0;
my $__DIE__ = sub {
  if  (not($Parse::Template::CONFESS) and $Already_shown) {
    # Reset when the eval() processing is finished
    $Already_shown = 0 if defined($^S);
    return;
  }
  # evaluated expressions are not always available in (caller(1))[6];
  if (defined($1) and $1 ne '') {
    my $expr = $1;		# what is the template expression?
    { package DB;		# what is the part name?
      @DB::caller = caller(1);
      @DB::caller = caller(2) unless @DB::args;
    };
    #local $1;
    $expr =~ s/package\s+${PACKAGE}::\w+\s*;//o;
    my $line = 0;
    $expr =~ s/^/sprintf "%2s ", ++$line/egm;
    $expr =~ s/\n;$//;
    my $part = defined $DB::args[1] ? $DB::args[1] : '';
    if ($Already_shown) {
      print STDERR "call from part '$part':\n$expr\n";
    } else {
      print STDERR "Error in part '$part':\n$expr\n";
    }
  }
  else {
    print STDERR "\$1 not defined";
  }
  print STDERR "\$1: $1\n";
  # ignore Already_shown if you won't confess your exception
  $Already_shown = 1 unless $Parse::Template::CONFESS;
};
$Parse::Template::SIG{__WARN__} = sub { # don't know how to suppress this:
  print STDERR "$_[0]"
    unless ($_[0] =~ /^Use of uninitialized value in substitution iterator/)
};

use constant EVAL_TRACE => 0;
use constant SHOW_PART => 0;
use constant SIGN_PART => 0;
$Parse::Template::SIGN_START = "# Template %s {\n"; # not documented
$Parse::Template::SIGN_END = "# } Template %s\n"; # not documented
my $indent = 0;
my @part = ();
sub eval {
  print STDERR do {
    local $" = q!', '! ; '..' x ++$indent, "=>eval('@_')\n"
  } if EVAL_TRACE;
  my $self = shift;
  my $part = shift;		# can't declare $part in eval()
  push @part, $part;
  my $class = ref $self || $self;
  my $text = $self->getPart($part);
  print STDERR qq!$part content: $text\n! if SHOW_PART;
  if (SIGN_PART) {		# not documented
    $text =~ s!^!sprintf $Parse::Template::SIGN_START, $part!e;
    $text =~ s!$!sprintf $Parse::Template::SIGN_END, $part!e;
  }
  local $SIG{__DIE__} = $__DIE__;
  # eval expression in class
  $text =~ s( %% (.*?) %% ){	# the magical substitution
    print STDERR '..' x $indent, "Eval part name: $part\n" if EVAL_TRACE;
    print STDERR '..' x $indent, "  expr: package $class;\n$1\n" if EVAL_TRACE;
    "package $class; $1";
  }eegsx;
  print STDERR "after: $class - $1\n" if EVAL_TRACE;
  die "$@" if $@;		# caught by __DIE__
  pop @part; $part = $part[-1];
  --$indent if EVAL_TRACE;
  $text;
}
1;
__END__