File Coverage

blib/lib/HTML/Myasp.pm

Criterion	Covered	Total	%
statement	15	104	14.4
branch	0	72	0.0
condition	0	8	0.0
subroutine	5	8	62.5
pod	0	3	0.0
total	20	195	10.2

package HTML::Myasp;

require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw/send_page/;

require 5.005_62;
use strict;
use warnings;

our $VERSION = '0.05';

use Carp;
use Data::Dumper;

my %CACHE;
our $DEBUG = 0;

our %g_hparam;
our %g_hreplace;

#-----------------------------------------------------------------------------------------------
sub add_sub_entry {

%g_hparam = (%g_hparam, @_);

}

#-----------------------------------------------------------------------------------------------
# add an entry in the direct replace hash (the second)
sub add_replace_entry {

%g_hreplace = (%g_hreplace, @_);

}

#-----------------------------------------------------------------------------------------------
sub send_page {

	local $SIG{__DIE__} = \&Carp::confess;

	my ($file, $hparam, $hreplace) = @_;

	map {$hparam->{$_} = $g_hparam{$_} } keys %g_hparam;
	map {$hreplace->{$_} = $g_hreplace{$_} } keys %g_hreplace;

	print STDERR "Sub Routine reference hash is\n"	if $DEBUG;
	warn Dumper $hparam								if $DEBUG;
	print STDERR "Direct replacing hash\n"			if $DEBUG;
	warn Dumper $hreplace							if $DEBUG;

	my $tagprefix;

	my ($source, $string_text);
	if (length($file) > 128) {
		$source = 'string';
		$string_text = $file;
		$file = substr($file,0,255);
	} else {
		$source = 'file';
	}

	warn "Source is coming from a $source" if $DEBUG;

	if (exists $ENV{MOD_PERL}) {
		my $r = Apache->request();
		$file = $r->document_root() . "/$file";  # if mod_perl the document root is prefixed to the file path
		$tagprefix = $r->dir_config("TagPrefix") || 'myasp';
	} else {
		$tagprefix = 'myasp';
	}

	$tagprefix = $ENV{TagPrefix} if $ENV{TagPrefix}; # always environment variables can change behavior

	warn "TagPrefix is $tagprefix" if $DEBUG;

	my $mtime = $source eq 'file' ? (stat($file))[9] : time;

	my ($package,$filename,$line) = caller;
	my $caller_mtime = (stat($filename))[9];

	if (!$CACHE{$file} || $mtime > $CACHE{$file}->{load_time} || $caller_mtime > $CACHE{$file}->{caller_mtime}) {

		warn "File $file reloaded or loaded first time" if $DEBUG;

		if ($source eq 'file') {
			use IO::File;
			my $fh = new IO::File;
			unless ($fh->open("<$file")) {
				print "Archivo no encontrado: $file";
				return;
			}
			local $/ = undef;
			$CACHE{$file}->{f_text} = <$fh>;
			close $fh;
		} else {
			 $CACHE{$file}->{f_text} = $string_text;
		}

		$CACHE{$file}->{load_time} = time;
		$CACHE{$file}->{caller_mtime} = time;


		my ($last, @data);

		while ($CACHE{$file}->{f_text} =~ m#(.+?)<$tagprefix:(.+?)(\s.+?)?>(.*?)#gs) {

			warn "$2 mark found" if $DEBUG;

			my %arr;
			if ($3) {
				my $aux = $3;
				$aux =~ s/^\s+//; $aux =~ s/\s+$//;

#				while (my ($key, $value) = $aux =~ /(\S+)=("[^"]"|\S+)/gs) {
#					$arr{$key} = $value;
#				}

				%arr = split /=|\s+/, $aux;

				foreach (keys %arr) {
					$arr{$_} =~ s/"//g;
				}
			}
			push @data, {-html => $1, -type=>'html'};
			push @data, {-name=>"-$2", -coderef => $hparam->{"\-$2"}, -type=>'cod', -param_ref => \%arr, -param_body => $4} if $hparam->{"\-$2"};

			$last = $';

		}
		if (@data) {
			push @data, {-html => $last, -type=>'html'};
		} else {
			push @data, {-html =>$CACHE{$file}->{f_text}, -type=>'html'};
		}

		$CACHE{$file}->{data} = \@data;

	} else {
		warn "Cache Hit file $file" if $DEBUG;
	}


	# the tags fields in the page are

	print STDERR "Begin parsed data file ***********\n" 	if $DEBUG;
	warn Dumper $CACHE{$file}								if $DEBUG;
	print STDERR "End parsed data file ***********\n" 		if $DEBUG;

	foreach my $x (@{$CACHE{$file}->{data}}) {
		if ($x->{-type} eq 'html') {
			next unless $x->{-html};
			my $temp = $x->{-html};
			print STDERR "Checking HTML replacing keywords\n" if $DEBUG;
			warn $temp								if $DEBUG;

			foreach my $key (keys %$hreplace) {
				warn "Checking key \"${key}\" and replacing with \"$hreplace->{$key}\"" if $DEBUG;

				if ($temp =~ s/\b${key}\b/$hreplace->{$key}/gis) {
					warn "String $key replaced" if $DEBUG;
				}
			}
			print $temp;
		} else {

			warn "Calling function $x->{-name}"											if $DEBUG;
			&Carp::cluck ("Stack de llamadas") 											if $DEBUG;
			print STDERR "The atributes of the tag are\n"								if $DEBUG;
			warn Dumper $x->{-param_ref}												if $DEBUG;
			print STDERR "*** Begin body between the marks is \n$x->{-param_body}\n"	if $DEBUG;
			print STDERR "*** End body between the marks\n"								if $DEBUG;

			unless (ref($hparam->{$x->{-name}})) {
				warn "Tag in template but not a handler subroutine defined: key $x->{-name}, template $file, called from $filename line $line";
				next;
			} else {
				&{$hparam->{$x->{-name}}}($x->{-param_ref}, $x->{-param_body});
			}
		}

	}

	1;

}




1;
__END__