File Coverage

blib/lib/CGI/FastTemplate.pm

Criterion	Covered	Total	%
statement	93	147	63.2
branch	24	48	50.0
condition	1	3	33.3
subroutine	12	17	70.5
pod	13	16	81.2
total	143	231	61.9

##################################################
##
## Name: CGI::FastTemplate
##
##        Copyright (c) 1998-99 Jason Moore .  All rights
##        reserved.
##
##        This program is free software; you can redistribute it and/or
##        modify it under the same terms as Perl itself.
##
##        This program is distributed in the hope that it will be useful,
##        but WITHOUT ANY WARRANTY; without even the implied warranty of
##        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##        Artistic License for more details.
##
##
## Credits:
##        - fancy regexp taken from article by Brian Slesinsky
##        http://www.hotwired.com/webmonkey/code/97/21/index2a_page4.html?tw=perl
##
##        - modified regexp to support ${VAR} and $VAR styles suggested by Eric L. Brine
##
##
## Documentation:
##        See
##        'perldoc CGI::FastTemplate'
##        or
##        'perldoc ./FastTemplate'
##
## History:
##        See 'README'
##
## $Id: FastTemplate.pm,v 1.2 1999/06/27 02:12:23 jmoore Exp $
##
##################################################

package CGI::FastTemplate;

use strict;

$CGI::FastTemplate::VERSION     = '1.09';
$CGI::FastTemplate::ROOT        = undef;

$CGI::FastTemplate::VAR_ID          = '$';
$CGI::FastTemplate::DELIM_LEFT      = '{';
$CGI::FastTemplate::DELIM_RIGHT     = '}';

##
## define indexes for object attributes
##

sub STRICT          () {0};
sub namespace       () {1};
sub namespaces      () {2};
sub last_parse      () {3};
sub template_name   () {4};
sub template_data   () {5};
sub ROOT            () {6};


##################################################
##
sub new
##
##   - instantiates FastTemplate
##
{
   my($class,$root) = @_;
   my $self = [];
   bless $self, $class;

   $self->init;

   $self->[STRICT]   = 1;

   if (defined($root))
   {
      $self->set_root($root);
   }
   return($self);
}

##################################################
##
sub strict
##
{
   my($self) = shift;
   $self->[STRICT] = 1;
}

##################################################
##
sub no_strict
##
{
   my($self) = shift;
   $self->[STRICT] = undef;
}

##################################################
##
sub clear_all
##
##   - initializes (or clears!) variables
##
{
   my($self) = shift;

   if (!ref($self))
   {
      print STDERR "FastTemplate: Unable to call init without instance.\n";
      return();
   }

   $self->[namespace]   = {};   ## main hash where we resolve variables
   $self->[namespaces]   = [];   ## array of hash refs

   $self->[last_parse]   = undef;   ## remember where we stored the last parse so print()
                  ## will have a default

   $self->[template_name]   = {};   ## template name: template file
   $self->[template_data]   = {};   ## template name: template content/data
}
*init = \&clear_all;      ## alias to 'clear' : 'init'

##################################################
##
sub clear_define
##
##   - clears values entered with define()
##
{
   my($self) = shift;
   $self->[template_name]   = {};
}

##################################################
##
sub clear_tpl
##
##   - clears hash that holds loaded templates.
##   - if passed an array of names, clears only those loaded templates
##
{
   my($self) = shift;
   my @args = @_;

   if (@args == 0)         ## clear entire cache
   {
      $self->[template_data]   = {};
      return(1);
   }

   ## clear just a selection of entries

   for (@args)
   {
      delete( ${$self->[template_data]}{$_} );
   }

   return(1);
}


##################################################
##
sub clear_href
##
##   - removes from the end, a given number of hash references
##     from the namespace list.
##
##   - 1: number of hash references to erase
##
{
   my($self, $number) = @_;

   if (!defined($number))
   {
      $self->[namespaces] = [];
      return(1);
   }

   for (1..$number)
   {
      pop(@{$self->[namespaces]});   ## toss it away
   }

   return(1);
}

#################################################
##
sub clear_parse
##
##   - clears hash which holds parsed variables
##   - if called with a scalar only clears that key/element in the namespace.
##     so, $tpl->clear("ROWS") which is almost the same as,
##     $tpl->assign(ROWS => "");
##
##   - if called with an array, all keys in the array are deleted
##     e.g. $tpl->clear("ROWS", "COLS"); has the same effect as
##          $tpl->assign(ROWS => "",
##                       COLS => "");
##
##
{
        my $self = shift;

        if (@_ == 0)                                    ## clear everything
        {
                $self->[namespace]      = {};           ## main hash where we resolve variables
                $self->[last_parse]     = undef;        ## remember where we stored the last parse so print()
                return(1);
        }

        for (@_)
        {
                delete(${$self->[namespace]}{$_});
        }
        return(1);
}

*clear = \&clear_parse;            ## alias clear -> clear_parse

##################################################
##
sub set_root
##
##   - sets template root directory.
{
    my($self, $root) = @_;

    ## set object default root directory

    $CGI::FastTemplate::ROOT = $root;

    ## set instance template dir
    ##
    ## - no needed
    ##

    if (ref($self))
    {
        $self->[ROOT] = $root;
    }

    return(1);
}

##################################################
##
sub define
##
##   - sets alias/name to associate with template filenames
##   - note: names are relative to ROOT directory (set with set_root)
##   - e.g. the following works
##       $tpl->set_root("/tmp/docs");
##       $tpl->define( main => "../dev_docs");
##       (assuming you have templates in /tmp/dev_docs)
##
##   - files are not loaded until used, so go nuts when defining.  each line
##     only costs a wee bit of memory and compile time.
##
##   - note: define is cumulative
##
{
    my($self, %define) = @_;

    for (keys(%define))
    {
        $self->[template_name]->{$_} = $define{$_};
    }

    return(1);
}

##################################################
##
sub assign
##
##   - assigns values of a HASH directly to internal namespace
##     HASH
##
##   Args:
##   - 1: hash reference (to add to array of namespaces)
##   - 1: hash (to merge with main namespace hash)
##
##   - returns: 1 on success
##
{
    my $self = shift;

    if (ref($_[0]) eq "HASH")
    {
        push(@{$self->[namespaces]}, $_[0]);
        return(1);
    }

    my %assign = @_;

    my($name,$value);
    while ( ($name,$value) = each(%assign) )
    {
        $self->[namespace]->{$name} = $value;
    }

    return(1);
}


##################################################
##
sub parse
##
##   - parses a scalar to resolve/interpolate any variables
##     it finds.
##
##   - 1: hash of what we are parse in TARGET:SOURCE form
##        NOTE: SOURCE with a "." as the first character get appended
##        to existing TARGET
##
{
    my($self, %parse) = @_;

    my $target;
    for $target (keys(%parse))
    {
        ##
        ## make all sources an array...
        ##

        if (ref($parse{$target}) ne "ARRAY")
        {
            $parse{$target} = [$parse{$target}];
        }

        my($p, $append);

        for $p (@{$parse{$target}})
        {
            if (substr($p,0,1) eq ".")   ## detect append
            {
                $append = 1;
                $p = substr($p, 1);
            }

            if (!exists($self->[template_name]{$p}))
            {
                print STDERR "FastTemplate: Template alias: $p does not exist.\n";
                next;
            }

            ## load template if we need to

            if (!exists($self->[template_data]{$p}))
            {
                $self->slurp($self->[template_name]->{$p}, \$self->[template_data]->{$p} );
            }

            ## copy SOURCE (template_data) to temp variable
            ## (can't use namespace, since we might be appending to it.)

            my $temp_parse = $self->[template_data]->{$p};

            #########
            ## parse
            #########

            $temp_parse =~ s/\$(?:([A-Z][A-Z0-9_]+)|\{([A-Z][A-Z0-9_]+)\})/

            my $v = $self->[namespace]->{$+};

            if (!defined($v))
            {
                ## look in array of hash refs for value of variable
                my $r;
                for $r (@{$self->[namespaces]})
                {
                    if (exists($$r{$+}))   ## found it
                    {
                        $v = $$r{$+};
                        last;
                    }
                }
            }
            if (!defined($v))       ## $v should be empty not undef, to prevent
            {                       ## warnings under -w
                if ($self->[STRICT])
                {
                    print STDERR "[CGI::FastTemplate] Warning: no value found for variable: $+\n";
                    $v = '$' . $+;      ## keep original variable name in output
                }
                else
                {
                    $v = "";      ## remove variable name
                }
            }
            $v;
            /ge;

            $self->[last_parse] = $target;
            ## assign temp to final TARGET

            if ($append)
            {
                $self->[namespace]->{$target} .= $temp_parse;
            }
            else
            {
                $self->[namespace]->{$target} = $temp_parse;
            }
        }
    }
}

##################################################
##
sub slurp
##
##  - slurps (loads) in file into a scalar.
##  - cool trick to undef the end of line character
##    grabbed from some usenet posting.  (don't remember)
##
##  - i think the maximum file size is (2**32-1) approx. 2 megs.
##
##  - 1: filename (minus path)
##  - 2: reference to put result in [optional]
##  returns: scalar
##
##
{
    my($self, $filename, $ref) = @_;
    my $temp;

    if (ref($self) && defined($self->[ROOT]))               ## use instance ROOT
    {
        $filename = $self->[ROOT] . "/" . $filename;
    }
    elsif (defined($CGI::FastTemplate::ROOT))               ## use object ROOT
    {
        $filename = $CGI::FastTemplate::ROOT . "/" . $filename;
    }

    if (!open(TEMPLATE, $filename))
    {
        print STDERR "FastTemplate: slurp: cannot open: $filename ($!)";
        return();
    }

    ## cool trick!

    local($/) = undef;
    $temp =