escape results from the CPAN

Apache-PSP

package Template::PSP;

require 5.005;

use strict;

use Carp;

use HTML::Parser;
use IO::Scalar;
use DBI; 
use vars qw($VERSION);

$VERSION = 1.00;

# %tags        - list of special HTML tags defined in Template.pm
# %global_tags - list of HTML tags, accessible by all pages
#
# $page       - scalar reference to script being created from template
# $frags      - html fragments
# $outputflag - process '$' variables
# $perlflag   - perl code
# $package    - template is being placed in $package
# %tagdata    - data associated with tag being created
# %Cache      - file time stamps for loaded psp pages
# %Handler    - pointers to subroutines for psp pages
# %type       - subroutines for handling output types

use vars qw (%tags %global_tags $page $parsefile $frags $outputflag $perlflag
	     $handlerflag $package %tagdata %Cache %Handler %type $lineno
	     $top_package $escapeflag $space
	    );

use vars qw(%QUERY %CGI %FILENAMES %AUTH %COOKIE);

%tags = map {$_ => 1} 
	( "tag", "loop", "if", "else", "elseif", "perl", "fetch", "output", 
	"handler", "return", "include", "pspescape" );

sub cleanup
{
  no strict 'refs';
  push(@{$top_package . "::cleanup_handler"}, shift);
}

sub cleanup_handler
{
  my $handlers = shift(@_);
  
  for (my $i=0;$handlers->[$i];$i++)
  {
    &{$handlers->[$i]}();
  }
}

sub setpvar
{
  my $item = shift;
  my $value = shift;
  if ($item)
  {
    no strict 'refs';
    ${$top_package . "::" . $item} = $value;
  }
}

sub getpvar
{
  my $item = shift;
  no strict 'refs';
  return ${$top_package . "::" . $item};
}

# derive the absolute path based on a
# relative filename and the current file
# 
# thanks to Scott Kiehn
#
sub abs_path
{
  my $file = shift(@_);
  
  my $prefix = substr($file, 0, 1);
  
  # if this is not an absolute path, 
  # create an absolute path from it
  if ($prefix ne '/')          
  {
    # check for document root abbreviation
    if ($prefix eq '~')     
    {
      $file = substr($file, 1);
      $file = $ENV{DOCUMENT_ROOT} . $file;
    }
    # otherwise use relative path based on the current file
    else                        
    {
      $file = substr( $parsefile, 0, rindex($parsefile, '/') ) . "/" . $file;

lib/Template/PSP.pm view on Meta::CPAN

  # fill %QUERY with query values
  my $cgi = CGI::Minimal->new();
#  %QUERY = map { my $x = [$cgi->param($_)]; $_ => scalar(@{$x}) > 1 ? \@{$x} : $$x[0] } ($cgi->param);
  # canonically-correct (and possibly temporary) expansion
  %QUERY = ();
  my @params = $cgi->param();
  foreach my $p (@params)
  {
    my @items = $cgi->param($p);
    if (scalar(@items) > 1)
    {
      $QUERY{$p} = \@items;
    }
    else
    {
      $QUERY{$p} = $items[0];
    }
  }

  
  # process cookies for this request
  my $cgi = CGI::Minimal->new();
  %COOKIE = ();
  my @cookies = split(/; ?/,$ENV{HTTP_COOKIE});
  foreach my $item (@cookies) 
  {
    my ($name, $value) = split('=', $item);
    $COOKIE{$name} = $cgi->url_decode($value);
  }
  
  # leave authorization for another time
#  if ($ENV->{HTTP_AUTHORIZATION}) 
#  {
#    my @list = split(/ /, $ENV{HTTP_AUTHORIZATION});
#    if (lc($list[0]) eq "basic") 
#    {
#      my $encoded = pop(@list);
#      my $decoded = decode_base64($encoded);
#  
#      ($AUTH->{username}, $AUTH->{password}) = split(/:/, $decoded);
#    }
#  }
  
  return 1;
}

#########################################
# Template::PSP::Parser
# used to process psp pages using HTML::Parser

sub start
{
  my $tagname = lc(shift);
  my $attr = shift;
  my $text = shift;

  no strict 'refs';

  default($text);

  if ($escapeflag || $tagname eq $tagdata{name} || $perlflag)
  {
    text($space . $text);
    $space = "";
    return;
  }

  # start tag
  if ($tags{$tagname})
  {
    no strict 'refs';
    &{$tagname}($attr);
    return;
  }

  my $fn = ${$package . "::custom_tags"}{$tagname} || $global_tags{$tagname};

  if ($fn)
  {
    append_page('&' . $fn . '({');
    
    foreach my $item (keys %{$attr})
    {
      my $s;
      my $s2;
      my $arg = ${$attr}{$item};
      $s2 = substr($arg,0,1);
      $s = substr($arg,1,1);
      
      if (($s2 eq '$') ||
          (($s2 eq "\\") &&
           ($s eq '@') ||
           ($s eq '%') ||
           ($s eq '&')
          )
         )
      {
        # don't quote because arg is a reference
        append_page("'$item'", '=>', $arg . ',');
      }
      else
      {
        if ($arg !~ /^@/)
        {
          $arg =~ s/@/\\@/gs;
        }
        $arg =~ s/{/\\{/g;
        $arg =~ s/}/\\}/g;
        append_page("'$item'", '=>', 'qq{' . $arg . '},');
      }
    }
    
    append_page('});'  . "\n");
    return;
  }
  
  text($space . $text);
  $space = "";
  return;
}

sub end
{
  my $tagname = lc(shift);
  my $text = shift;

  default($text);

  if (($escapeflag && $tagname ne "pspescape") ||
      ($tagname eq $tagdata{name}) ||
      ($handlerflag && $tagname ne "handler") ||
      (!$handlerflag && $perlflag && $tagname ne "perl"))
  {
    text($space . $text);
    $space = "";
    return;
  }

  if ($tags{$tagname})
  {
    no strict 'refs';
    &{$tagname . "_"}();
    return;
  }

  no strict 'refs';

  my $fn = $global_tags{$tagname . "_"} ||
           ${$package . "::custom_tags"}{$tagname . "_"};

  if ($fn)
  {
    no strict 'refs';
    append_page('&' . $fn .'();' . "\n");
    return;
  }
  
  text($space . $text);
  $space = "";
  return;
}

# for comments,
# display the comment as provided
sub comment
{
  my ($text) = @_;
  default($text);

  text($space . $text);
  $space = "";
  return;
  
  return;
}

sub default
{
  my ($text) = @_;
  $lineno += count_lines($text);
}

# handles all text that is read by the parser
sub text
{
  my ($text) = @_;

  if (!$escapeflag && $text =~ /^\s*$/s)
  {
    $space = $text;
    return;
  }
  if ($perlflag)
  {
    append_page($text);
  }
  elsif ($outputflag)
  {
    $text =~ s/\@/\\\@/g;
    append_page('print qq{' . $text . '};' . "\n");
  }
  else
  {
    no strict 'refs';
    $frags++;
    ${$package . '::__html_' . $frags} = $text;
    append_page("print \$" . $package . '::__html_' . $frags . ";\n");;
  }
}


#########################################
# BEGIN TAG DEFINITIONS
#
# The tag TAG allows building of non-looping tags.
# three parameters can be passed:
# name - name of tag to create
# body - if set to nonzero, the tag being defined contains
#     a body
# output - if set to nonzero, the tag being defined will
#     evaluate variables that begin with '$' 


sub tag
{
  my ($attr) = @_;
  my (@attrs) = split(/,/, $attr->{accepts});

  # Try to hide global variables for building tag in
  # %Template::PSP::tagdata

  $tagdata{body} = $attr->{body};
  if ($tagdata{body})
  {
    push(@attrs, "body");
  }
  $tagdata{global} = $attr->{global};
  $tagdata{name} = lc($attr->{name});
  $tagdata{oldpage} = $page;
  $page = \$tagdata{page};

  # For each new tag, create a Perl function 
  # which will be called when the start tag is 
  # encountered

  append_page('package', $package . ";\n");
  append_page("no strict 'refs';\n");
  append_page('sub', $tagdata{name}, "{\n");

lib/Template/PSP.pm view on Meta::CPAN

  $perlflag--;
}

# The <fetch> tag searches the %type hash for a handler.
# If no handler is found, we assume that the user
# is outputting global scalars.  New output types can
# be easily added by adding handlers to the %type hash.

sub fetch {
    my ($attr) = @_;
    my ($handler) = $type{$attr->{type}};
    my @fetch = split(/,/, $attr->{fetch});

    if (defined($handler)) {
	my $attrs;
	$attrs .= "[";
	foreach my $item (@fetch) {
	    $attrs .= "\"$item\",";
	}
	$attrs .= "]";
	    
	my $startrow = $attr->{startrow} || 0;
	my $endrow = $attr->{endrow};

	append_page("#line $lineno $parsefile\n"); 
	append_page('for (my $i=' . $startrow . '; (my $results = &{$Template::PSP::type{'
		    . lc($attr->{type})
		    . '}}($' . $attr->{query} . ' || getpvar("'
		    . $attr->{query}
		    . '"), $i, '
		    . $attrs
		    . '))' );
	if ($endrow) {
	    append_page('&& $i <' . $endrow);
	}
	append_page('; $i++) {' . "\n");
    } else {
	append_page("{\n");
	append_page('my $results = $'.$attr->{query}.' || getpvar("'.$attr->{query}."\");\n");
    }
    foreach my $item (@fetch) {
        append_page("my \$$item =", '$results->{' . $item. '};' . "\n");
    }
}

sub fetch_ {
    append_page("}\n");
}

sub output 
{
    $outputflag++;
}

sub output_ 
{
  $outputflag--;
  $outputflag = 0 if $outputflag < 0;  
}

sub pspescape 
{
  $escapeflag++;
}

sub pspescape_ 
{
  $escapeflag--;
  $escapeflag = 0 if $escapeflag < 0;  
}

sub include 
{
  my ($attr) = @_;
 
  my $file     = eval qq{"$attr->{file}"};
  $file = abs_path($file);

  if (! -f $file) 
  {
    croak "Cannot include file '", $attr->{file}, 
          "' while processing $parsefile\n";
  }
  
  pspload($file);
  
  append_page('&{&Template::PSP::pspload(' . "'$file'" . ')}();' . "\n");
}

sub include_ {}

# load the rest of the tags
foreach my $filename qw(Tags.psp autoform.psp)
{
  my $tags_file;
  
  foreach my $path (@INC)
  {
    my $test = $path . "/Template/PSP/$filename";
    
    if (-e $test)
    {
      $tags_file = $test;
      last;
    }
  }
  
  if ($tags_file)
  {
    eval { pspload($tags_file, "Template::PSP"); };
    if ($@)
    {
      warn "WARNING: Can't load optional tags from $tags_file. " .
           "Some global tags may not be available.\n";
    }
  }
}

#########################################
# MISC FUNCTIONS

# checks if file has changed on disk
sub newfile {
    my $file = shift;
    my $mtime = -M "$file";

    if (!defined($Cache{$file}) || $Cache{$file} != $mtime) {
	$Cache{$file} = $mtime;
	return 1;

( run in 1.034 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )