File Coverage

blib/lib/HTML/Processor.pm

Criterion	Covered	Total	%
statement	12	509	2.3
branch	0	158	0.0
condition	0	137	0.0
subroutine	4	48	8.3
pod	6	36	16.6
total	22	888	2.4

package HTML::Processor;

use strict;
use vars qw($VERSION $syntax_pre $syntax_post @ISA);

require Exporter;

@ISA = qw(Exporter);

$VERSION = '0.2.1';

#----------------------------------------------
# Constructor for Template Object
#----------------------------------------------
sub new {
	# new Template
	my $proto 		= shift;
	my $config_ref 	= shift; # hash of config options

    # BEGIN CONFIG ////////////////////////////////
    # These are template defaults and can be changed
    # prior to installation or over-ridden when
    # setting up the object
    my %config = (
    	clean		=> 0,
        escape      => 0,
    	debug		=> 'Off',
    	footprint	=> 1,
    	syntax_pre	=> '\[TPL ',
    	syntax_post	=> '\]'
    );
    # END CONFIG //////////////////////////////////


    my $class = ref($proto) || $proto;
    my $self  = {
	        PATHS       => {},
            DEBUG_LEVELS=> {
                Fatal	=> 3,
            	Normal	=> 2,
            	Verbose	=> 1,
            	Off		=> 0
            },
	 		DEBUG_LEVEL	=> {},
			FOOTPRINT	=> {},
	 		CLEAN		=> {},
            ESCAPE		=> {},
			NESTS		=> {},
			LOOPS	    => {},
			VARIABLES	=> {},
			OPTIONS		=> {},
			INCLUDES	=> {},
			HEADER		=> undef
    };

	# set up configs with passed data or default
	$self->{ DEBUG_LEVEL } 	= $self->{DEBUG_LEVELS}{ $config_ref->{ debuglevel } } 	|| $self->{DEBUG_LEVELS}{$config{ debug }};
	$self->{ FOOTPRINT } 	= $config_ref->{ footprint } 					|| $config{ footprint };
	$self->{ CLEAN } 		= $config_ref->{ clean } 						|| $config{ clean };
    $self->{ ESCAPE } 		= $config_ref->{ escape } 						|| $config{ escape };
	$syntax_pre				= $config_ref->{ syntax_pre }					|| $config{ syntax_pre };
	$syntax_post			= $config_ref->{ syntax_post }					|| $config{ syntax_post };
	bless($self, $class);

	# debug the debug level!
	if($config_ref->{ debuglevel } && !exists $self->{DEBUG_LEVELS}{ $config_ref->{ debuglevel } }){
		$self->debug("param",3,"Invalid debug level: '$config_ref->{ debuglevel }' not one of (". join(", ", keys %{$self->{DEBUG_LEVELS}}) . ")",3);
	}
    return $self;
}


#----------------------------------------------
# Constructor for Loop Object
#----------------------------------------------
sub new_loop {
    my $self = shift;
    my $name = shift;
	my $nest = shift;

	if($nest){
		push @{ $self->{ NESTS }->{$name}->{ KEYS } }, $nest;
		$name = "${name}~${nest}";
	}
	$self->{ LOOPS }->{$name} = HTML::Processor::Loop->new();
	return $self->{ LOOPS }->{$name};  # return a handle
}

#----------------------------------------------
# build variables
#----------------------------------------------
sub variable {
	my $self = shift;
	my $name = shift;
	my $val  = shift;

	$self->{ VARIABLES }{$name} = $val if( defined $val );
	return $self->{ VARIABLES }{$name};

}

#----------------------------------------------
# concatenate variable value with input
#----------------------------------------------
sub concat {
	my $self 	= shift;
	my $name 	= shift;
	my $val  	= shift;
	my $invert	= shift;

	if ( $invert ) {
		$self->{ VARIABLES }{$name} = $val . $self->{ VARIABLES }{$name};
	}
	else{
		$self->{ VARIABLES }{$name} .= $val;
	}
    return $self->{ VARIABLES }{$name};
}

#----------------------------------------------
# perform basic maths on a variable
#----------------------------------------------
sub math {
    my $self 	= shift;
	my ( $var, $val, $opr, $invert ) = @_;
	my $result;
	my %operands = (
		'+' => \&addition,
		'-' => \&subtraction,
		'*' => \&multiplication,
		'/' => \&division,
	);
	# check if this is a valid variable
	if(!$self->{ VARIABLES }{$var}){
		$self->debug("process",3,"'$var' is an un-declared variable, can't do math");
	}
	# check if this is a valid operand
	elsif(!$operands{$opr}){
		$self->debug("process",3,"'$opr' is not a valid math operand from('+', '-', '*','/')");
	}
	else {
		# retrieve the values
		my $val_val = ( exists $self->{ VARIABLES }{ $val } ) ? $self->{ VARIABLES }{ $val } : $val;
		my $var_val = $self->{ VARIABLES }{ $var };

		my @pair = ($invert) ? ($val_val, $var_val) : ($var_val, $val_val);
		$result = &{ $operands{$opr} }( \@pair );
	}
	$self->variable($var, $result);
	return $result;
}

#----------------------------------------------
# build included files
#----------------------------------------------
sub include {
	my $self = shift;
	my $name = shift;
	my $file = shift;

	$self->{ INCLUDES }{ $name } = $file if ( $file );
	return $self->{ INCLUDES }{ $name };
}
#----------------------------------------------
# Add base paths
#----------------------------------------------
sub add_path {
    my $self = shift;
    my $path = shift;

    $self->{ PATHS }->{ $path }++;
}

#----------------------------------------------
# build options
#----------------------------------------------
sub option {
    my $self = shift;
	my $name = shift;
	my $val = shift;

	$self->{ OPTIONS }{ $name } = $val if ( $val );
    return $self->{ OPTIONS }{ $name };
}

#----------------------------------------------
# Print a value and exit
#----------------------------------------------
sub print_die {
	my $self = shift;
	my $data = shift;

	print "Content-type: text/html \n\n";
	print $data;
	exit;
}

#----------------------------------------------
# print content inline 4 debugging
#----------------------------------------------
sub print {
	my $self 		= shift;
	my $data 		= shift;
	my $line_end 	= shift;
	if(!$self->{ HEADER }){
		# print a header on first pass
		print "Content-type: text/html \n\n";
		$self->{ HEADER } = 1;
	}
	print $data . ($line_end || "\n");
}

#----------------------------------------------
# Print a value and exit
#----------------------------------------------
sub error {
	my $self = shift;
	my $data = shift;
	my $app	 = shift;

	my( $file, $line, $pack, $sub ) = id(1);
	print "Content-type: text/html \n\n";
	my $out = qq|$app Software Error:
$data
at: $file line: $line

|;
	print $out;
	exit;
}

#----------------------------------------------
# Set clean on||off
#----------------------------------------------
sub set_clean {
	my $self = shift;
	my $state = shift;

	$self->{ CLEAN } = $state || 0;
}

#----------------------------------------------
# Set escape on||off
#----------------------------------------------
sub set_escape {
	my $self = shift;
	my $state = shift;

	$self->{ ESCAPE } = $state || 0;
}
#----------------------------------------------
# Set footprint on||off
#----------------------------------------------
sub set_footprint {
	my $self = shift;
	my $state = shift;

	$self->{ FOOTPRINT } = $state || 0;
}

#----------------------------------------------
# Set config options
#----------------------------------------------
sub set_config {
	my $self = shift;
	my $state = shift;

	# define cofig for various states
	my %states = (
		'email' => {
			FOOTPRINT 	=> 0,
			CLEAN 		=> 0
		},
		'default' => {
			FOOTPRINT 	=> 1,
			CLEAN 		=> 1
		}
	);
	# set config params according to passed state
	if( $states{$state} ){
		foreach my $func(keys %{ $states{$state} }){
			$self->{$func} = $states{$state}->{$func};
		}
	}
}

#----------------------------------------------
# Sort a loop by one of its keys
#----------------------------------------------
sub sort {
	my $self 		= shift;
	my $sortby		= shift;


	# return if there is not sort by values
	return unless $sortby;

	$self->{ SORTBY } = $sortby;
	my ( $dir, $loop, $sort_on );
	my @sorts = reverse split( /-/, $sortby );

	# test the sort key for: dir - sorton - loop
	if ( @sorts == 3 ) {
		$dir        = lc $sorts[0];
		$sort_on    = $sorts[1];
		$loop       = $sorts[2];
	}
	elsif (@sorts == 2 && (lc $sorts[0] eq "asc" || lc $sorts[0] eq "desc")){
		$dir        = lc $sorts[0];
		$sort_on    = $sorts[1];
	}
	elsif (@sorts == 2 && (lc $sorts[0] ne "asc" || lc $sorts[0] ne "desc")){
		$dir        = "asc";
		$sort_on    = $sorts[0];
		$loop       = $sorts[1];
	}
	elsif (@sorts == 1){
		$dir = "asc";
		$sort_on = $sorts[0];
	}

	# if we don't have an loop to sort on yet - go find one
	my @multiples;
	if ( !$loop ) {
		foreach my $loop_name ( keys %{ $self->{ LOOPS } }){
			# use the last loop that tests true
			if($self->{ LOOPS }->{ $loop_name }->{ $sort_on }){
				$loop = $loop_name;
				push @multiples, $loop_name;
			}
		}
		# die if we have more than 1 possible loop
		$self->debug("parse",
					 3,
					 "sort called without specifying loop & " .
					 "multiple possible loops [" .
					 join(", ", @multiples) .
					 "] found for sort key: $sort_on"
					 ) if @multiples > 1;
	}

	if($self->{ LOOPS }->{ $loop }{$sort_on}){
		my @sortkeys = @{ $self->{ LOOPS }->{ $loop }{$sort_on} };
		# check if data is string or int
		my $data_type = ($sortkeys[0] =~ /(\D)/ && $1 !~ /\.|\,/) ? "STRING" : "INT";
        if ( $data_type eq "INT" ) {
            # strip commas
            $sortkeys[$_] =~ s/,//g for 0..$#sortkeys;
        }
		my %sortcode = (
			"STRING-asc" 	=> sub { return sort { uc $sortkeys[$a] cmp uc $sortkeys[$b] } 0..$#sortkeys },
			"STRING-desc"	=> sub { return sort { uc $sortkeys[$b] cmp uc $sortkeys[$a] } 0..$#sortkeys },
			"INT-asc"		=> sub { return sort {    $sortkeys[$a]   <=>  $sortkeys[$b] } 0..$#sortkeys },
			"INT-desc"		=> sub { return sort {    $sortkeys[$b]   <=>  $sortkeys[$a] } 0..$#sortkeys }
		);
		my @sorted =  &{ $sortcode{"${data_type}-${dir}"} };
		$self->{ LOOPS }->{ $loop }{$_} = [ @{$self->{ LOOPS }->{ $loop }{$_}}[@sorted] ] for keys %{ $self->{ LOOPS }->{ $loop } };
	    $self->{ SKEYS } = [@sorted];

        # sort the bg colours if there are any
        #--------------------------------------------------------
        if ( $self->{ LOOPS }->{ $loop }{ 'bgcolor' } ) {

            # get the unique colours
            my %colours;
            foreach my $colour ( @{ $self->{ LOOPS }->{ $loop }{ 'bgcolor' } } ){
                $colours{ $colour }++;
                last if ( scalar keys %colours >= 2 );
            }
            # if we have 2 to work with
            if ( keys %colours == 2 ) {
                # create the colour toggle
                my $toggle = $self->create_toggle( keys %colours );
                my $colour;
                # reset each of the bgcolour elements
                for ( my $i = 0; $i < scalar @{ $self->{ LOOPS }->{ $loop }{ 'bgcolor' } }; $i++ ){
                    $colour = $toggle->( $colour );
                    $self->{ LOOPS }->{ $loop }{ 'bgcolor' }->[$i] = $colour;
                }
            }
        }

    }
	else {
		$self->debug("parse",2,"sortby called with non-existent sort key: $loop => $sortby");
	}
}

#--------------------------------------------
# toggle a colour
#--------------------------------------------
sub create_toggle {
    my $self = shift;
    my ( $primary, $secondary ) = @_;

    my $current = $secondary;
    return sub {
        my $cur_ref = \$current;
        $$cur_ref = ($$cur_ref eq $primary) ? $secondary : $primary;
        return $$cur_ref;
    }
}

#--------------------------------------------------
# generic subroutine for creating HTML dropdowns
#--------------------------------------------------
sub create_dropdown {

	my $self = shift;
	my ( $itr_name, $ref_array_id, $ref_array_name, $selected_id, $selected_name ) = @_;
	# create loop
	my $itr = $self->new_loop($itr_name);
	my $count = 0;
	# populate loop
	foreach my $id ( @$ref_array_id ) {
		my $name = ( $ref_array_name ) ? $$ref_array_name[$count++] : '';
		my $type_selected = '';

		$itr->array("id", $id);
		$itr->array("name", $name || $id);
		# is this the selected item?
		if ( $selected_id ) {
			$type_selected = ( $selected_id eq $id ) ? " SELECTED" : "";
		}
		else {
			$type_selected = ( $selected_name eq $name ) ? " SELECTED" : "";
		}
		$itr->array("selected", $type_selected);
	}
}

#----------------------------------------------
# Parse and Return the template
#----------------------------------------------
sub process {
	my $self 			= shift;
	my $template_path 	= shift;
	my $debug_object	= shift;

	# prepend template path and name to output if footprint is set
	my $template = ($self->{ FOOTPRINT }) ? "\n" : "";

	# check for a template file on line 1 of template path
	if ( (split /\n/, $template_path)[0] =~ /\.\w{3,4}$/ ) {
		# we're processing a file

        # if the file is not found: check if its relative to a stored path
        unless ( -e $template_path ) {
            foreach my $stored_path ( keys %{ $self->{ PATHS } } ) {
                # check if the template exists at the stored PATH location
                if ( -e ($stored_path . $template_path) ) {
                    $template_path = $stored_path . $template_path;
                    last;
                }
            }
        }

		local $/ = undef; # undef record separator for reading file into scalar
		open (READFILE, $template_path) or $self->debug("file",3,"Can't open content file : $template_path $!");
		$template .= ;
		close READFILE;

	}
    else {
        # we're processing a data block
		$template = $template_path;
		# set base path to Cwd for includes from data
		use Cwd;
        $template_path = cwd;
	}

    $self->{ TEMPLATE } = $template_path;

	# process the html template
	$self->do_includes		(\$template,\$template_path);
	$self->do_options		(\$template);
	$self->do_ifelse		(\$template);
	$self->do_variables		(\$template);
	$self->do_loops     	(\$template);
	$self->do_sort_dir		(\$template) if $self->{ SORTBY };
	$self->do_clean			(\$template) if $self->{ CLEAN };

	# if we are dumping object data
	if( $debug_object ){
		use Data::Dumper;
		# take a copy of the object
        my $debugObj = $self;
        # clean up the object before debug display
        delete $debugObj->{ IT_STACK };
        delete $debugObj->{ DEBUG_LEVELS };
		$template .= "" . Dumper( $debugObj ) . "";
	}
	# add debug data
	$template .= $self->build_err if($self->{ DEBUG_LEVEL } > 0);

	return $template;
}



#=========================================================
# PRIVATE METHODS
#=========================================================

#=====================================
# math private methods
#=====================================
sub addition {
	my $pair = shift;
	my ($this, $that) = @$pair;
	return $this + $that;
}

sub subtraction {
	my $pair = shift;
	my ($this, $that) = @$pair;
	return $this - $that;
}

sub multiplication {
	my $pair = shift;
	my ($this, $that) = @$pair;
	return $this * $that;
}

sub division {
	my $pair = shift;
	my ($this, $that) = @$pair;
	return $this / $that;
}

#=====================================

#=====================================
# change the sort direction
#=====================================
sub do_sort_dir {
	my $self 				= shift;
	my $template_ref 		= shift;

	return if $self->{ SORTBY } =~ /ASC|DESC/;
	my $out;
	my $skey = $self->{ SORTBY };
	$skey =~ /(asc|desc)/;
	my $dir = $1;
	my $dirout = ($dir eq "desc") ? "asc" : "desc";
	if ( $dir ) {
		$out = $skey;
		$out =~ s/$dir/$dirout/;
	}
	else {
		$out = $skey . "-$dirout";
	}
	$$template_ref =~ s/sort=$skey/sort=$out/o;

}

#=====================================
# include files into template
#=====================================
sub do_includes {
    my $self              = shift;
    my $template_ref      = shift;
    my $template_path_ref = shift;

    # use template path as root for includes
    if ( $$template_path_ref =~ m/\// ) {
        # if there is a path
        $$template_path_ref =~ s/(.*)(\/)(.*?)$/$1$2/;
    }
    else {
        # file name only
        $$template_path_ref = "";
    }
    # start paths library
    $self->{ PATHS }->{ $$template_path_ref } = 1;

    while ( $$template_ref =~ m/\A(.*)${syntax_pre}include='(.*?)'${syntax_post}(.*)\Z/msi ) {
        my $inc_pre  = $1;    # pre included file
        my $file     = $2;    # $variables name for file
        my $inc_post = $3;    # post include data
        my $filepath = '';

        if ( $file =~ /\./ ) {
            $filepath = $$template_path_ref . $file;
            my $filename;
            my $local_path = "";
            # has a path
            if ($file =~ /\// ) {
                $local_path = $file;
                $local_path =~ s/(.*)(\/)(.*?)(\.\w{3,4}$)/$1$2/;
                $filename = $3.$4;
            }
            else {
                $filename = $file;
            }
            # store path
            $self->{ PATHS }->{$$template_path_ref . $local_path}++;

            # if the file is relative to an included file
            unless ( -e $filepath ) {
                foreach ( keys %{ $self->{PATHS} } ) {
                    if ( -e $_ . $filename ) {
                        $filepath = $_ . $filename;
                    }
                }
            }
        }
        else {
            $filepath = $self->include($file);
        }

        my $footpre = ( $self->{FOOTPRINT} ) ? "\n\n" : "";
        my $footpost = ( $self->{FOOTPRINT} ) ? "\n\n\n\n" : "";

        # test for existence of file
        if ( -e $filepath ) {
            local $/ = undef;
            open( INCLUDE, "< $filepath" );
            my $inc_data = ;
            close(INCLUDE);
            $$template_ref = "$inc_pre$footpre$inc_data$footpost$inc_post";
        }
        # no file to include
        else {
            $$template_ref = $inc_pre . "" . $inc_post;
            $self->debug( "parse", 3, "File to include does not exist:'$filepath'" );
        }
    }
}
#=====================================
# evaluate optional content
#=====================================
sub do_options {
	my $self 		= shift;
	my $template_ref 	= shift;

	while ($$template_ref =~ m/\A(.*)${syntax_pre}OPTION name([ !=]+)'([\w\d-]*)'${syntax_post}(.*?)${syntax_pre}OPTION END${syntax_post}(.*)\Z/msi){
		my $opt_pre  = $1;
		my $opt_type = $2;
		my $opt_name = $3;
		my $opt_data = $4;
		my $opt_post = $5;
		# clean the option comarisons
		$opt_type =~ s/ //g;
		$opt_type =~ s/==/=/;

		my $test_val = $self->option($opt_name) || $self->variable($opt_name);

		if($opt_type eq "=" && $test_val){
			$$template_ref = $opt_pre.$opt_data.$opt_post;
		}
		elsif($opt_type eq "!=" && !$test_val){
			$$template_ref = $opt_pre.$opt_data.$opt_post;
		}
		# option fails
		else {
			# loose the optional content
			$$template_ref = $opt_pre.$opt_post;
		}
	}
}

#=====================================
# Evaluate If/Else clauses
#=====================================
sub do_ifelse {
    my $self         = shift;
    my $template_ref = shift;

    while ( $$template_ref =~ m/\A(.*)${syntax_pre}IF (\w+)([ =!<>]+)'([\w-]*)'${syntax_post}(.*?)(${syntax_pre}ENDIF${syntax_post})(.*)\Z/msi ) {
        my $if_pre    = $1;    # pre if data
        my $fs_var    = $2;    # first if variable
        my $fs_oper   = $3;    # first if operand
        my $fs_val    = $4;    # first value to test
        my $if_cont   = $5;    # block to do work on
        my $if_end    = $6;    # [ENDIF] end of string
        my $if_post   = $7;    # rest of template
        my $if_output = '';

        # test if the first is true
        if ( $self->compare( $fs_oper, $self->variable($fs_var), $fs_val ) ) {
            $if_cont =~ s/(.*?)${syntax_pre}(ELSIF|ELSE).*\Z/$1/msi if $if_cont =~ /${syntax_pre}(ELSIF|ELSE)/msi;
            $if_output = $if_cont;
        }
        # loop through remaining tests
        else {
            my $if_data = $if_cont . $if_end;

            # evaluate each ELSIF|ELSE
            while ( $if_data =~ m/${syntax_pre}(ELSIF|ELSE)(| (\w+)([ =!<>]+)'([\w-]*)')${syntax_post}(.*?)(${syntax_pre}(ELSIF|ELSE|ENDIF).*)\Z/msi ) {
                my $if_type    = $1;    # clause type (IF|ELSIF|ELSE)
                my $if_var     = $3;    # value to test
                my $oper       = $4;    # if operator
                my $if_val     = $5;    # value to test
                my $if_content = $6;    # output for the block
                my $if_tail    = $7;    # following IF/ELSE clauses

                # evaluate clauses
                if ( $if_type =~ /ELSIF|IF/ && $self->compare( $oper, $self->variable($if_var), $if_val ) ) {
                    $if_output = $if_content;
                    last;    # exit if there's a match
                }
                # use the else if above fails
                elsif ( $if_type =~ /ELSE/ ) {
                    $if_output = $if_content;
                }
                # truncate the string for each loop by what we just tested
                $if_data = $if_tail;
            }
        }
        $$template_ref = $if_pre . $if_output . $if_post;
    }
}


#=====================================
# replace loops
#=====================================
#my (%it_stack);
sub do_loops {
	my $self 			= shift;
	my $template_ref 	= shift;

    $self->{ IT_STACK } = {};

    while ( $$template_ref =~ m/\A(.*)${syntax_pre}LOOP name='([\w\d-]+)'${syntax_post}(.*?)${syntax_pre}LOOP END${syntax_post}(.*)\Z/msi) {
		my $it_pre 		= $1; 	# data before the loop block
		my $it_name		= $2;	# name of loop
		my $data 		= $3; 	# loop data to process
		my $it_post 	= $4; 	# data after the loop block

		# insert place holders
		$$template_ref = $it_pre."[LOOP:'$it_name']".$it_post;
		$self->debug("parse",1,"loop: $it_name not found in object") unless ( $self->{ LOOPS }{ $it_name } || $self->{ NESTS }{ $it_name });
		# push loop block to named hash of arrays,
		# allows for multiple loops of the same name
		push @{ $self->{ IT_STACK }->{$it_name} }, $data;
    }


	my (%multi);
	# add looped content to template
	while ($$template_ref =~ m/\A(.*)\[LOOP:'([\w\d-]+)'\](.*)\Z/msi){
		my $pre 	= $1;
		my $iter 	= $2;
		my $post 	= $3;

		# log duplicate loops
		$multi{$iter}++;
		# go iterate over loop
		$$template_ref = $pre.$self->iterate_loop( $iter, $self->{ IT_STACK }->{$iter}[$multi{$iter}-1] ).$post;
	}
}

#=====================================
# loop processing
#=====================================
#my (%parents);
sub iterate_loop {
	my $self 	= shift;
	my $it_name = shift;
	my $dat_ref	= shift;
	my $p_count = shift;
	my ($iterated);
	my $input_name = $it_name;

	# initialise position counter
	# start at -1 so ++ on first pass gives 0
	#if(!exists $parents{$input_name}){ $parents{$input_name} = -1 };
	$self->{ PARENTS }{$input_name} = $self->{ PARENTS }{$input_name} || -1;

	# if we are processing a nest - indicated by passed value for
	# 'p_count' (parent counter)
	if($p_count ne ''){
		# use sort keys for position if we have a sorted parent
        my $position = ( $self->{ SKEYS } ) ? $self->{ SKEYS }[$p_count] : $p_count;
		my $it_key = $self->{ NESTS }->{$it_name}->{ KEYS }[$position];
		$it_name = "${it_name}~${it_key}";
	}

	my $max_count = 0;
	# get the longest array for this loop
	foreach (keys %{ $self->{ LOOPS }->{$it_name} }){
		if(ref $self->{ LOOPS }->{$it_name}->{$_} eq "ARRAY"){
			my $a_length = @{$self->{ LOOPS }->{$it_name}->{$_}};
			$max_count = $a_length if ( $a_length > $max_count );
		}
	}

	# loop for the length of the longest array
	for (my $count = 0; $count < $max_count; $count++) {
	    my $loop = $dat_ref; # deref & scope loop data
	    while ($loop =~ m/\A(.*)${syntax_pre}array='([\w\d-]*)'${syntax_post}(.*)\Z/msi) {
			my $ins_pre = $1;
			my $ins_name = $2;
			my $ins_post = $3;

			my $it_val = $self->{ LOOPS }->{$it_name}->{$ins_name}[$count];
			$it_val = $self->escape_html($it_val) if $self->{ ESCAPE };# ***
			# build the output for this instance
			$loop = $ins_pre.$it_val.$ins_post;
	    }
		# increment the count for this pass
		$self->{ PARENTS }{$input_name}++;

		# Loop Option processing
		#---------------------------------------------------
		while ($loop =~ m/\A(.*)${syntax_pre}LOOP OPTION name(!=|=)'([\w\d-]*)'${syntax_post}(.*?)${syntax_pre}LOOP OPTION END${syntax_post}(.*)\Z/msi){
			my $opt_pre = $1;
			my $opt_type = $2;
			my $opt_name = $3;
			my $opt_data = $4;
			my $opt_post = $5;
			my $opt_itr_val;

			# check if there is an explicit options setting
			if(exists $self->{ LOOPS }->{$it_name}->{ OPTIONS }->{$opt_name}){
				$opt_itr_val = $self->{ LOOPS }->{$it_name}->{ OPTIONS }->{$opt_name}[$count];
			}
			# otherwise look for the 'array' in the current loop
			elsif(exists $self->{ LOOPS }->{$it_name}->{$opt_name}){
				$opt_itr_val = $self->{ LOOPS }->{$it_name}->{$opt_name}[$count];
			}
			else {
				$self->debug("process",2,"The loop option: '$opt_name' cannot be found");
			}

			# if the option variable is true
			if ($opt_itr_val && $opt_type eq "="){
				$loop = $opt_pre.$opt_data.$opt_post;
			}
			# if the option variable is not true
			elsif (!$opt_itr_val && $opt_type eq "!="){
				$loop = $opt_pre.$opt_data.$opt_post;
			}
			else {
				# loose the optional content
				$loop = $opt_pre.$opt_post;
			}
		}
		 # Loop if/else processing
        #---------------------------------------------------------
        while ( $loop =~ m/\A(.*)${syntax_pre}LOOP IF (\w+)([ =!<>]+)'([\w-]*)'${syntax_post}(.*?)(${syntax_pre}LOOP ENDIF${syntax_post})(.*)\Z/msi ) {
            my $if_pre    = $1;    # pre if data
            my $fs_var    = $2;    # first if variable
            my $fs_oper   = $3;    # first if operand
            my $fs_val    = $4;    # first value to test
            my $if_cont   = $5;    # block to do work on
            my $if_end    = $6;    # [ENDIF] end of string
            my $if_post   = $7;    # rest of template
            my $if_output = '';

            # test if the first is true
            if ( $self->compare( $fs_oper, $self->{LOOPS}->{$it_name}->{$fs_var}[$count], $fs_val ) ) {
                $if_cont =~ s/(.*?)${syntax_pre}LOOP (ELSIF|ELSE).*\Z/$1/msi if $if_cont =~ /${syntax_pre}LOOP (ELSIF|ELSE)/msi;
                $if_output = $if_cont;
            }
            # loop through remaining tests
            else {
                my $if_data = $if_cont . $if_end;

                # evaluate each ELSIF|ELSE
                while ( $if_data =~ m/${syntax_pre}LOOP (ELSIF|ELSE)(| (\w+)([ =!<>]+)'([\w-]*)')${syntax_post}(.*?)(${syntax_pre}LOOP (ELSIF|ELSE|ENDIF).*)\Z/msi ) {
                    my $if_type    = $1;    # clause type (IF|ELSIF|ELSE)
                    my $if_var     = $3;    # value to test
                    my $oper       = $4;    # if operator
                    my $if_val     = $5;    # value to test
                    my $if_content = $6;    # output for the block
                    my $if_tail    = $7;    # following IF/ELSE clauses

                    # evaluate clauses
                    if ( $if_type =~ /ELSIF|IF/ && $self->compare( $oper, $self->{LOOPS}->{$it_name}->{$if_var}[$count], $if_val ) ) {
                        $if_output = $if_content;
                        last; # exit if there's a match
                    }
                    # use the else if above fails
                    elsif ( $if_type =~ /ELSE/ ) {
                        $if_output = $if_content;
                    }
                    # truncate the sring each loop by what we just tested
                    $if_data = $if_tail;
                }
            }
            $loop = $if_pre . $if_output . $if_post;
        }

		# Nested Loop processing (recursive)
		#---------------------------------------------------------
		my %nest_multi;
		while ($loop =~ /\A(.*)\[LOOP:'([\w\d-]+)'\](.*)\Z/msi){
			my $curr_pre 	= $1;
			my $curr_nst 	= $2;
			my $curr_post 	= $3;

			$self->debug("parse",1,"loop: $it_name not found in object") unless $self->{ LOOPS }{ $it_name };

			# handle duplicate naming of nested loops
			$nest_multi{$curr_nst}++ ;
            my $thisdata = $self->iterate_loop( $curr_nst, $self->{ IT_STACK }->{$curr_nst}[$nest_multi{$curr_nst}-1], $self->{ PARENTS }{$input_name} );
			$loop = $curr_pre . $thisdata . $curr_post;

		}
		# add to iterated content
	    $iterated .= $loop;
	}
	return $iterated;
}

#=====================================
# replace normal variables
#=====================================
sub do_variables {
	my $self 			= shift;
	my $template_ref 	= shift;

    $$template_ref =~ s/${syntax_pre}variable='([\d\w-]+)'${syntax_post}/$self->{ ESCAPE } ? $self->escape_html($self->variable($1)) : ($self->variable($1) )/eg;
}


# encode html un-friendly entities
#----------------------------------
sub escape_html {
    my $self = shift;
    my $data = shift;
    my %esc = (
        '"'	 => '"',
        '&'  => '&',
        '<'  => '<',
        '>'  => '>'
    );
    $data =~ s/([\"<>])/$esc{$1}/g;
    return $data;
}

#=====================================
# Clean spaces
#=====================================
sub do_clean {
	my $self			= shift;
	my $template_ref 	= shift;

	# remove empty lines except in text areas
	$$template_ref =~ s/\s+\n/\n/sg unless $$template_ref =~ /textarea(.*?)\s+\n(.*?)\/textarea/msi;
	$$template_ref =~ s/\n\s+
}

#=====================================
# perform comparisons
#=====================================
sub compare {
	my $self	= shift;
	my $oper	= shift;
	my $left	= shift || 0;
	my $right	= shift || 0;
	$oper =~ s/ //g;

	if(
        ( $oper eq "="  && $left eq $right ) ||
		( $oper eq "==" && $left eq $right ) ||
		( $oper eq "!=" && $left ne $right ) ||
		( $oper eq "<"  && $left < $right )  ||
		( $oper eq "<=" && $left <= $right ) ||
		( $oper eq ">"  && $left > $right )  ||
		( $oper eq ">=" && $left >= $right ) ||
        ( $oper eq "LIKE" && $left =~ m/$right/ ) ||
        ( $oper eq "NOTLIKE" && $left !~ m/$right/ )
	  ) { return 1; }
	else { return 0; }
}

#=====================================
# debug template data
#=====================================
my $error_count;
sub debug {
	my $self 		= shift;
	my $type		= shift;
	my $level		= shift;
	my $msg			= shift;

	$$error_count++;
	# get caller data
	my( $file, $line, $pack, $sub ) = id(2);

	if( !$level ) { print "no debug level at: at $file line $line"; exit; }

	# insert the error in to the object hash
	$self->{ DEBUG }{ $level }{ $type }{ $$error_count }{ MSG } = $msg;
	$self->{ DEBUG }{ $level }{ $type }{ $$error_count }{ SUB } = $sub;
	$self->{ DEBUG }{ $level }{ $type }{ $$error_count }{ LOC } = "at $file line $line";

	# HIGH level debugging: print error and exit
	#---------------------------------
	if ( $level == $self->{DEBUG_LEVELS}{'Fatal'} ) {
		print $self->build_err($self->{DEBUG_LEVELS}{'Fatal'});
		exit;
	}

}
#===============================
# format error data
#===============================
sub build_err {
	my $self = shift;
	my $level = shift;

	# possible error types
	my %error_types = (
		param	=> "setup parameter",
		file	=> "file open / close / print",
		process	=> "building object data",
		parse	=> "parsing the html temlate"
	);
	my $level_type = $level || $self->{ DEBUG_LEVEL };

	# Shameless use of html for 'pretty' debugging
	# The module is, after all HTML::Processor
	my $error = qq|
		 </td>
</tr>

<tr>
<td  class="h" >
<a name="1021">1021</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 		.errlabel{ font: bold 12px verdana; } </td>
</tr>

<tr>
<td  class="h" >
<a name="1022">1022</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 		.errdata { font: normal 12px verdana; } </td>
</tr>

<tr>
<td  class="h" >
<a name="1023">1023</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 		.errhead { font: bold 14px verdana; border:1px solid #DDDDDD; background-color:#EEEEEE;} </td>
</tr>

<tr>
<td  class="h" >
<a name="1024">1024</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">
		|; } |; " . " . \n"; |;  




1026




 





 





 





 





 





 



 		Template Processing Debug Info: 




1027




 





 





 





 





 





 



 	|; 




1028




0




  
  0
  




 





 





 





 



 	if( $$error_count == 0 ) { $error .= qq|No bugs to report




 




0





 





 





 





 





 



   




1029




0





 





 





 





 





 



 	my %level_key = reverse %{ $self->{DEBUG_LEVELS} }; 




 




0





 





 





 





 





 



   




1030




0





 





 





 





 





 



 	foreach my $err_lvl(sort {{$b} <=> {$a}} keys %{ $self->{ DEBUG } } ){ 




 




0





 





 





 





 





 



   




 




0





 





 





 





 





 



   




1031




 





 





 





 





 





 



 		 




1032




 





 





 





 





 





 



 		# debug up to & including given level 




1033




0




  
  0
  




 





 





 





 



 		if($err_lvl >= $level_type) { 




1034




 





 





 





 





 





 



 		 




1035




0





 





 





 





 





 



 			foreach my $err_typ(keys %{ $self->{ DEBUG }{ $err_lvl } } ){ 




 




0





 





 





 





 





 



   




1036




 





 





 





 





 





 



 				 




1037




0





 





 





 





 





 



 				$error .= qq|GROUP: [$error_types{$err_typ}] LEVEL: $level_key{$err_lvl}




1038




 





 





 





 





 





 



 				 




1039




0





 





 





 





 





 



 				foreach my $err_num(sort {{$a} <=> {$b}} keys %{ $self->{ DEBUG }{ $err_lvl }{ $err_typ } } ){ 




 




0





 





 





 





 





 



   




 




0





 





 





 





 





 



   




1040




 





 





 





 





 





 



 					$error .= "sub:" .  




1041




 





 





 





 





 





 



 								$self->{ DEBUG }{ $err_lvl }{ $err_typ }{ $err_num } { SUB } . 




1042




 





 





 





 





 





 



 							"




1043




 





 





 





 





 





 



 							"what:" . 




1044




 





 





 





 





 





 



 								$self->{ DEBUG }{ $err_lvl }{ $err_typ }{ $err_num } { MSG } . 




1045




 





 





 





 





 





 



 							"




1046




 





 





 





 





 





 



 							"where:" . 




1047




 





 





 





 





 





 



 								$self->{ DEBUG }{ $err_lvl }{ $err_typ }{ $err_num } { LOC } . 




1048




0





 





 





 





 





 



 							"




1049




 





 





 





 





 





 



 				} 




1050




0





 





 





 





 





 



 				$error .= qq| 




1051




 





 





 





 





 





 



 			} 




1052




 





 





 





 





 





 



 		} 




1053




 





 





 





 





 





 



 	} 




1054




0





 





 





 





 





 



 	$error .= qq| 




1055

	|;
	if( $$error_count == 0 ) { $error .= qq|
	my %level_key = reverse %{ $self->{DEBUG_LEVELS} };
	foreach my $err_lvl(sort {{$b} <=> {$a}} keys %{ $self->{ DEBUG } } ){

		# debug up to & including given level
		if($err_lvl >= $level_type) {

			foreach my $err_typ(keys %{ $self->{ DEBUG }{ $err_lvl } } ){

				$error .= qq|

				foreach my $err_num(sort {{$a} <=> {$b}} keys %{ $self->{ DEBUG }{ $err_lvl }{ $err_typ } } ){
					$error .= "
								$self->{ DEBUG }{ $err_lvl }{ $err_typ }{ $err_num } { SUB } .
							"
							"
								$self->{ DEBUG }{ $err_lvl }{ $err_typ }{ $err_num } { MSG } .
							"
							"
								$self->{ DEBUG }{ $err_lvl }{ $err_typ }{ $err_num } { LOC } .
							"
				}
				$error .= qq|
			}
		}
	}
	$error .= qq|

	|;
	return $error;
}
#===============================
# get error location data
#===============================
sub id {
    my $level = shift;
    my ( $pack, $file, $line, $sub ) = caller($level);
    my ( $id ) = $file =~ m|([^/]+)\z|;
    return ( $file, $line, $pack, $sub );
}


package HTML::Processor::Loop;

#----------------------------------------------
# Constructor for Loop Object
#----------------------------------------------
sub new {
    my $proto = shift;

    my $class = ref( $proto ) || $proto;
    my $self  = {};

    bless( $self, $class );
    return $self;
}

#----------------------------------------------
#	iterarion array method
#----------------------------------------------
sub array {
	my $self = shift;
	my ( $name, $val ) = @_;

	push @{ $self->{$name} }, $val;

}


#----------------------------------------------
# build loop options
#----------------------------------------------
sub option {
    my $self = shift;
	my $name = shift;
	my $val = shift;
	my $posit = shift;

	push @{ $self->{ OPTIONS }->{$name} }, $val;
	return $self->{ OPTIONS }->{$name};
}
1;

__END__