package PSP::Parser;

# Copyright (c) 2000, FundsXpress Financial Network, Inc.
# This library is free software released under the GNU Lesser General
# Public License, Version 2.1.  Please read the important licensing and
# disclaimer information included below.

# $Id: Parser.pm,v 1.1.1.2 2003/12/06 19:47:26 hartmans Exp $

use strict;
$PSP::Parser::VERSION = '0.505';

=head1 NAME

PSP::Parser - Base Parser for PSP compilations.

=head1 SYNOPSIS

This package implements the base parser used by PSP::Compiler parsers.

=head1 DESCRIPTION

=head2 Top Level Internal Data

=cut

use Exporter;
use Error qw (:try);
use PSP::HTML::Parser;
use PSP::Utils qw(dump_object);
use HTMLIO::Utils qw(html_unescape);

BEGIN {
  @PSP::Parser::ISA = qw(Exporter PSP::HTML::Parser);
  @PSP::Parser::EXPORT_OK = qw(&register &register_tags &unregister_tags);
  $PSP::Parser::EXPORT_TAGS{all} = \@PSP::Parser::EXPORT_OK;
}

=head1 METHODS

=head2 new

=cut

sub new {
  my ($proto) = @_;

  #Create the PSP::HTML::Parser
  my $this = PSP::HTML::Parser->new();
  bless $this, ref $proto || $proto;

  #Configure the HTML::Parser
  $this->handler('section%',"jsection","self,text");

  # we maintain a local sense of "literal mode".
  $this->disallow_literal_mode(1);

  # support php-style scriptlets -- doesn't work:  parse_process
  $this->handler('section?psp,?',"jsection","self,text");

  #Currently constant:
  $this->{back_compat}    = 1;
  # current tag and text handlers.
  $this->{handlers_begin} = {};
  $this->{handlers_end}   = {};
  # stacks for text subroutines, code subroutines, and handlers.
  $this->{stack_text_sub} = [ \&push_text ];
  $this->{stack_code_sub} = [ \&push_page_code ];
  $this->{stack_handlers} = [];
  # seen files are kept for possible dependency output.
  $this->{depends}        = [];
  $this->{depends_h}      = {};
  # hrm
  $this->{is_cdata}         = undef;
  $this->{includepath}      = [];
  $this->{text_to_flush}    = "";
  $this->{current_code}     = "";
  $this->{current_indent}   = "";
  $this->{stack_decl}       = [""];
  $this->{prev_context}     = "NoContext";
  $this->{stack_context}    = [$this->{prev_context}];

  # to keep track of where we are parsing.
  $this->{current_line_n} = 1;
  $this->{current_fname}  = undef;

  # keep data of the preparser here.  (Necessary anymore?)
  $this->{preparsed} = {};

  # these properties get propagated to/from nested parsers.
  $this->{propagatable} =
    [qw(verbose debug n_errors
	pile_name seed includepath depends depends_h
	stack_text_sub stack_code_sub
	handlers_begin handlers_end
	current_code current_indent
	stack_decl stack_context prev_context
	back_compat preparsed input_dir
       )];

  #Execute the register() routine in each of the parser components.
  my $isa_var = '@'.ref($this).'::ISA';
  for my $class (eval $isa_var) {
    my $method = $class."::register";
    $this->can($method) and $this->$method($class);
  }

  return $this;
}

sub debug_line {
  my ($this,$text) = @_;
  $this->{debug} or return;

  my @caller = caller(1);
  my $func = $caller[3];
  $func =~ s/.*:://;
  $func =~ s/begin_psp/START-/;
  $func =~ s/end_psp/END-/;
  $func =~ s/call_//;

  my $out = "";
  $out .= "\U$func";
  if (defined $text) {
    $text =~ s/\n+$//;
    $text =~ s/\n/\\n/g;
    if ($text =~ /:$/) {
      $out .= " $text ";
    } else {
      $out .= " [[$text]]\n";
    }
  } else {
    $out .= "\n";
  }
  print $out;
}

sub include_files {
  my ($this,$parser) = @_;
  $parser ||= $this;
  my @include_files;
  for ( my $parser=$this; $parser; $parser = $parser->{parent_parser} ) {
    push @include_files, $parser->{current_fname}.":".$parser->{current_line_n};
  }
  return \@include_files;
}

sub log_exception {
  my ($this,$exception) = @_;

  # should we support other exception interfaces
  # to generate this warning message?
  #my $warning = ref $exception ? $exception->text : $exception;
  my $warning = $exception;

  # make sure it ends with a newline.
  $warning =~ s/\s*$/\n/s;

  # How might the offending filename and line number be represented?
  #$warning =~ /^\S+:\d+:/ or

  my @include_files = @{$this->include_files()};
  my $cur_dir = shift @include_files;

  $warning = $cur_dir.": ".$warning;
  @include_files and $warning .=
    join("",map {"\tincluded by $_\n"} @include_files);

  print STDERR $warning;
  #print dump_object($this)."\n\n";
}

sub tag_to_handler {
  my ($this,$tag) = @_;

  my $type = ($tag =~ s!^/!!) ? "end" : "begin";

  my ($name,$handler);

  # old-style mic tag compatibility hacks.
  #
  if ($tag =~ /^mic([^:].*)/i) {
    if ($1 eq "perl") {
      $name = "psp:script";
    } elsif ($1 eq "ignore") {
      $name = "psp:nop";
    } else {
      $name = "psp:\L$1";
    }
  } elsif ($tag =~ /^v(field|page|verify|current|instantiated)$/i) {
    $name = "psp:\L$tag";
  } elsif (defined $this->{back_compat} and $tag eq "form") {
    $name = "psp:\L$tag";
  }

  # warn when we recognize one of the above deprecated tags.
  #
  if ($name) {
    if (! defined $this->{back_compat}) {
      return($tag, "deprecated");
    } elsif (! $this->{back_compat}) {
      $this->log_exception("<$tag> is deprecated");
    }
  }

  # process new-style tags.
  #
  if (! $name and $tag =~ /^psp:(.*)$/i) {
    $name = "psp:".$1;
  }

  # if we have a name, find a handler.
  #
  if ($name) {
    $handler = $this->{"handlers_".$type}->{$name};
    if (!$handler) {
      # if we don't have a handler for this tag, and we're in cdata,
      # then just allow the original text to pass through as text.
      if ($this->{is_cdata}) {
	return($name, "text");
      } else {
	return($name, "unrecognized ".ref($this)." extension.");
      }
    }
  }

  # return the handler info.
  return ($name,$handler);
}

=head2 start

 [private] instance
 () start (string $tag, \%attrs, \@attrseq, string $origtext)

DESCRIPTION:

Overides the B<HTML::Parser> function of the same name. Is called by
the parser when a begin tag is encountered. This will call the proper
function for PSP defined tags.

=cut

sub start {
  my ($this, $tag, $attr, @args) = @_;
  my ($name,$handler) = $this->tag_to_handler($tag);
  # micfieldspace attribute compatibility hack:
  if ($this->{back_compat}) {
    if (my $fs = delete $attr->{micfieldspace}) {
      $attr->{fieldspace} = $fs;
    }
    # micdo attribute compatibility hack:
    if ($tag eq "micdo") {
      my $name = delete $attr->{group};
      my $field = delete $attr->{name};
      $attr->{name} = $name;
      $attr->{field} = $field;
    }
    if ($tag =~ /^(microllto|microllback|microllover|micrefresh)$/) {
      my $group = $attr->{assocdynamic};
      $attr->{group} = $group;
    }
  }
  $this->call_handler($name,$handler,$tag,$attr,@args);
  if (defined $attr->{'/'}) {
    ($name,$handler) = $this->tag_to_handler("/".$tag);
    if (ref $handler or (defined $handler and
			 ($handler eq "text" or $handler eq "code"))) {
      $this->call_handler($name,$handler,"/".$tag,@args);
    }
  }
}

=head2 end

 [private] instance
 () end (string $tag)

DESCRIPTION:

Overides B<HTML::Parser> function of the same name. Is called to
handle end tags. Will call the appropriate subroutine for PSP defined
tags.

=cut

sub end {
  my ($this, $tag, @args) = @_;
  my ($name,$handler) = $this->tag_to_handler("/".$tag);
  $this->call_handler($name,$handler,"/".$tag,@args);
}

=head2 jsection

 [private] instance
 () jsection (string $tag)

DESCRIPTION:

Overides B<HTML::Parser> function of the same name. Is called to
handle general tags.  Will call the appropriate subroutine for PSP defined
tags.

=cut

sub jsection {
  my ($this, $body) = @_;

  try {

    if ($body eq "") {
      $this->debug_line("empty");

    } elsif ($body =~ /^--/) {
      $this->debug_line((length($body)+4)." comment bytes ignored");

    } elsif ($body =~ /^\s*@\s*(.+?)\s*$/) {
      my $directive = $1;
      if ($directive =~ /^include\s+file\s*=\s*['"]?(.+?)["']?\s*$/) {
        $this->can("begin_pspinclude") and
          $this->begin_pspinclude("jdirective",{src=>$1},['src'],$body);
      } else {
        throw Error::Simple("Jdirective ''$directive'' not supported.");
      }

    } elsif ($body =~ s/^!//) {
      $this->call_handler("jdecl","decl",$body);

    } elsif ($body =~ /^=/) {
      $this->call_handler("jtext","text","[$body=]");

    } else {
      $this->call_handler("jcode","code",$body);
    }

  } catch Error::Simple with {
    $this->{n_errors}++;
    $this->log_exception(@_);
  };

}

=head2 declaration

=cut

sub declaration {
  my ($this,$decl) = @_;
  $this->text("<!$decl>");
}


=head2 eof

 [private] instance
 () eof (string $tag)

DESCRIPTION:

=cut

sub eof {
  my ($this) = @_;
  my $ret = $this->SUPER::eof();
  $this->flush();
  return $ret;
}

=head2 call_handler

 [private] instance
 () call_handler (string $tag)

DESCRIPTION:

Overides B<HTML::Parser> function of the same name. Is called to
handle general tags.  Will call the appropriate subroutine for PSP defined
tags.

=cut

sub call_handler {
  my ($this,$handler_name,$handler,@args) = @_;

  # @args are passed to a handler subroutine.
  # $orig is used for text and code methods.
  # $end is for debugging.  
  #
  my $orig = $args[-1];
  my $end  = (@args == 2 and 
	      (!$handler_name or $handler_name ne 'text')) ? "end:" : "";

  try {

    # use the input subroutine.
    #
    if (ref $handler eq 'CODE') {
      $this->debug_line("${end}$handler_name transfer: $handler");
      no strict; 
      &{$handler}($this,@args);
      use strict;

    # use the code method.
    #
    } elsif ($handler and $handler eq 'code') {
      #$this->debug_line("${end}$handler_name: transfer to code");
      $this->code($orig);

    # use the decl method.
    #
    } elsif ($handler and $handler eq 'decl') {
      #$this->debug_line("${end}$handler_name: transfer to decl");
      $this->decl($orig);

    # use the text method.
    #
    } elsif (! $handler or $handler eq 'text') {
      #$this->debug_line("${end} transfer to text");
      $this->text($orig);

    # the handler is an exception string when it is not used above.
    #
    } else {
      $this->debug_line("${end}$handler_name: $handler");
      my $tag  = $args[0];
      throw Error::Simple("invalid use of <$tag>: $handler\n");
    }

  } catch Error::Simple with {
    $this->{n_errors}++;
    $this->log_exception(@_);
  };

  $this->{current_line_n} += ($orig =~ tr/\n/\n/);
  return;
}

=head2 text_mode 

 [private] instance
 () text_mode ([boolean enter=1])

DESCRIPTION:

A tag handler should invoke this method when the tag will contain
non-script text.  The end-tag handler should call this method with
"0" as its argument to close the scope.

=cut

sub text_mode {
  my ($this,$enter) = @_;
  defined $enter or $enter = 1;
  if ($enter) {
    $this->push_text_sub(\&push_text);
  } else {
    if ($this->{stack_text_sub}->[-1] ne \&push_text) {
      $this->log_exception("Error: attempted to leave non-text-mode");
    } elsif (!$this->pop_text_sub()) {
      $this->log_exception("text_mode() stack underflow.");
    }
  }
}

=head2 script_mode 

 [private] instance
 () script_mode ([boolean enter=1])

DESCRIPTION:

A tag handler should invoke this method when the tag will contain
script text.  The end-tag handler should call this method with
"0" as its argument to close the scope.

=cut

sub script_mode {
  my ($this,$enter) = @_;
  defined $enter or $enter = 1;
  if ($enter) {
    $this->push_text_sub(\&push_script);
  } else {
    if ($this->{stack_text_sub}->[-1] ne \&push_script) {
      $this->log_exception("Error: attempted to leave non-script-mode");
    } elsif (!$this->pop_text_sub()) {
      $this->log_exception("script_mode() stack underflow.");
    }
  }
}

=head2 text

 [private] instance
 (string $textout) text (string $textin)

DESCRIPTION:

This function overides the B<HTML::Parser> function of the same
name. It is called on all plain text in the document.  We use the
top reference to a subroutine accessed by C<text_sub> off the
B<PSP::Parser> so that we can modify the behavior of this subroutine
based on what container tags we are within.

=cut

sub text {
  my ($this, $text) = @_;
  $this->debug_line("switch: $text");
  $this->{current_line_n} += ($text =~ tr/\n/\n/);
  no strict;
  my $ret_val;
  try {
    $ret_val = &{$this->{stack_text_sub}->[-1]}($this, $text);
  } catch Error::Simple with {
    $this->{n_errors}++;
    $this->log_exception(@_);
  };
  use strict;
  return $ret_val;
}

sub pop_text_sub {
  my ($this) = @_;
  $this->debug_line(scalar(@{$this->{stack_text_sub}}));
  @{$this->{stack_text_sub}} > 1 and return pop @{$this->{stack_text_sub}};
}

sub push_text_sub {
  my ($this,$sub) = @_;
  $this->debug_line(@{$this->{stack_text_sub}}." + $sub");
  $sub and return push @{$this->{stack_text_sub}}, $sub;
}

sub code {
  my ($this, $text) = @_;
  $this->debug_line("switch");
  no strict;
  my $ret_val;
  try {
    # get rid of extra new lines and blank space.
    $text =~ s/\n\s*\n+/\n\n/g;

    # this can prevent recursion between flush_text and code().
    $text eq "" and return;

    # flush: empty the text buffer into the code buffer.
    $this->flush_text();
 
    $ret_val = &{$this->{stack_code_sub}->[-1]}($this, $text);

  } catch Error::Simple with {
    $this->{n_errors}++;
    $this->log_exception(@_);
  };
  use strict;
  return $ret_val;
}

sub pop_code_sub {
  my ($this) = @_;
  $this->debug_line(scalar(@{$this->{stack_code_sub}}));
  @{$this->{stack_code_sub}} > 1 and return pop @{$this->{stack_code_sub}};
}

sub push_code_sub {
  my ($this,$sub) = @_;
  $this->debug_line(@{$this->{stack_code_sub}}." + $sub");
  $sub and return push @{$this->{stack_code_sub}}, $sub;
}

sub decl {
  my ($this,$text) = @_;
  $this->debug_line($text);
  $this->{stack_decl}->[-1] .= $text; #."\n";
}

sub push_decl {
  my $this = shift;
  my $text = join('', @_);
  $this->debug_line(scalar(@{$this->{stack_decl}}));
  push @{$this->{stack_decl}}, "";
  $this->decl($text) if defined $text;
}

sub pop_decl {
  my ($this) = @_;
  $this->debug_line(scalar(@{$this->{stack_decl}}));
  return pop @{$this->{stack_decl}};
}

=head2 push_script

 [private] instance
 () push_script (string $text);

DESCRIPTION:

This function handles text when parser is in script context.

=cut
  
sub push_script {
  my $this = shift;
  my $chunk = html_unescape(join("",@_));
  $this->debug_line($chunk);
  $this->code($chunk);
};

=head2 push_text

 [private] instance
 () push_text (string @text_lines)

DESCRIPTION:

Push all the elements of the argument list into the data structure
C<text_to_flush>.

=cut

sub push_text {
  my $this = shift;
  my ($text) = join('', @_);
  $this->{'text_to_flush'} .= $text;
}

=head2 %test_wrappers

 %test_wrappers ( String SYMBOL => Code FILTER )

DESCRIPTION:

When text is wrapped in '[' SYMBOL <text> SYMBOL ']', set text to 
output of the filter operating on that text.

=cut

use vars qw(%text_wrappers);
%text_wrappers = 
  ('-' => sub { return "HTMLIO::Utils::uri_escape($_[0])" },
   '+' => sub { return "HTMLIO::Utils::html_escape($_[0])" },
   '=' => sub { return $_[0] } );

=head2 flush

 [private] instance
 () flush ()

DESCRIPTION:

Flush the current html by converting it into the appropriate script
code.  Right now, this only calls flush_text() but maybe more someday.

=cut

sub flush {
  my ($this,@args) = @_;
  $this->flush_text(@args);
}

=head2 flush_text

 [private] instance
 () flush_text ()

DESCRIPTION:

Flush the current html by converting it into the appropriate script
code.

=cut

sub flush_text_prep {
  my ($this,$text) = @_;

  # escape trouble characters.
  $text =~ s/([\\""\$\@\%])/\\$1/og;
  # collapse different kinds of space.
  $text =~ s/\s*\n\s*\n+/\n\n/g;
  $text =~ s/^\n\n/\\n/;
  $text =~ s/^\s+$// or
    $text =~ s/\s*\n\s*\n\s*$/\n\n/ or 
      $text =~ s/\s*\n\s*$/\n/ or 
	$text =~ s/\s+$/ /;
  # escape any final newlines.
  $text =~ s/\n\n$/\\n\\n/s;
  $text =~ s/\n$/\\n/s;
  # escape all newlines if the text is short.
  length($text) < 60 and $text =~ s/\n/\\n/g;

  return $text;
}
sub flush_text_chunks {
  my ($this,$text) = @_;

  my @chunks;
  while ($text =~ /\[([+=-])(.*?)([+=-])\]/s) {
    #warn "'[$1' does not match with '$3]'\n" unless $1 eq $3;
    my ($type, $code) = ($1, $2);
    $text = $';

    # write any text before the substitution.
    if (my $prev = $this->flush_text_prep($`)) {
      push @chunks, "\"$prev\"";
    }

    # write the substitution code.
    $code =~ s/\n/ /go;
    $code =~ s/;\s*$//o;
    no strict;
    $code = &{$text_wrappers{$type}}(PSP::HTML::Entities::decode($code));
    use strict;
    push @chunks, $code;
  }

  # write any remaining text.
  if (my $final_text = $this->flush_text_prep($text)) {
    push @chunks, "\"$final_text\"";
  }
  return @chunks;
}
sub flush_text_str {
  my ($this,$text) = @_;
  return join(".\n",$this->flush_text_chunks($text));
}
sub flush_text {
  my $this = shift;

  my $text = $this->{text_to_flush};
  $this->{text_to_flush} = "";
  $this->debug_line($text);

  my @chunks = $this->flush_text_chunks($text) or return;

  my $out = '$out->put(';
  my $sep = "";
  for my $chunk (@chunks) {
    $out .= $sep.$chunk;
    $sep = ".\n".$this->code_indent()."       ";
  }
  $out .= ");";
  $this->code($out);
}

=head2 code_indent

=head2 code_add_indent

=head2 code_del_indent

=cut

sub code_indent {
  my ($this,$indent) = @_;
  defined $indent and $this->{current_indent} = $indent;
  return $this->{current_indent};
}
sub code_add_indent ($$) {
  my ($this,$indent) = @_;
  $this->{current_indent} .= $indent;
}
sub code_del_indent ($$) {
  my ($this,$indent) = @_;
  $this->{current_indent} =~ s/$indent$//;
}

=head2 push_page_code

 [private] instance
 () push_page_code (string @code_lines)

DESCRIPTION:

First, flush any pending html.  Then, push the script code specified in
the join of C<@code_lines> onto C<current_code>.

=cut

sub push_page_code {
  my ($this,$text) = @_;
  $this->debug_line($text);
  $this->append_code($text);
  if (0) { my $d = $this->{current_code};
    $d =~ s/\n/\\n/g; print "CURRENT_CODE NOW [$d]\n"; }
}

=head2 append_code

=cut

sub append_code {
  my ($this,$text,$text_ref) = @_;
  $text_ref ||= \$this->{current_code};
  $$text_ref =~ s/;$/;\n/;
  $$text_ref =~ /\n$/s and
    $$text_ref .= $this->code_indent();
  $$text_ref .= $text;
}

=head2 page_code

 [private] instance
 (string $page_code) page_code ()

DESCRIPTION:

Returns accumulated page code after flushing the html.

=cut

sub page_code {
  my ($this) = @_;
  $this->flush();
  (my $out = delete $this->{current_code}) =~ s/\s+$//s;  
  $this->debug_line($this->{current_code});
  $this->{current_code} = "";
  return $out;
}

sub pile_name {
  my ($this,$val) = @_;
  $this->{pile_name} = $val if defined $val;
  return $this->{pile_name};
}

sub page_name {
  my ($this,$val) = @_;
  if (defined $val) {
    $this->{page_name} = PSP::Utils::path_to_page_name($val);
  }
  return $this->{page_name};
}

sub push_handlers {
  my ($this,$begin,$end) = @_;
  $this->debug_line(@{$this->{stack_handlers}}." + $begin + $end");
  $begin or $begin = {};
  $end   or $end = {};
  push @{$this->{stack_handlers}}, [$this->{handlers_begin},
				    $this->{handlers_end}];
  $this->{handlers_begin} = $begin;
  $this->{handlers_end} = $end;
}

sub pop_handlers {
  my ($this) = @_;
  $this->debug_line(scalar(@{$this->{stack_handlers}}));
  my ($begin,$end);
  if (@{$this->{stack_handlers}}) {
    ($begin,$end) = @{$this->{stack_handlers}->[-1]};
    pop @{$this->{stack_handlers}};
    $this->{handlers_begin} = $begin;
    $this->{handlers_end} = $end;
    return($begin,$end);
  }
}

sub handlers {
  my ($this) = @_;
  return($this->{handlers_begin},$this->{handlers_end});
}

sub dump_handlers {
  my ($this,$begin,$end) = @_;
  $begin or $begin = $this->{handlers_begin};
  $end or $end = $this->{handlers_end};
  print "Dump of begin=$this->{handlers_begin} and end=$this->{handlers_end}\n";
  for my $key (sort keys %$begin) {
    print "begin:$key = $begin->{$key}\n";
  }
  for my $key (sort keys %$end) {
    print "end:$key = $end->{$key}\n";
  }
}

=head2 parse_file

 instance
 () parse_file (string $page,string \@incpath)

DESCRIPTION:

Called to parse files. C<$page> should be the file\'s location.

=cut

sub parse_file {
  my ($this, $path, $incpath) = @_;
  $this->debug_line($path);

  # if we are given an include path, assign it to the parser object
  # so that sub-parsers have access to it, but return this parser
  # to its previous state before leaving this method.
  my $orig_incpath;
  if ($incpath) {
    $orig_incpath = delete $this->{includepath};
    $this->{includepath} = $incpath;
  }

  # assign the page_name before it is recombined with incpath.
  if (!$this->page_name() and $path !~ /\.fs$/) {
    my $input_dir = $this->{input_dir};
    my $page_name = $path;
    $page_name =~ s!^$input_dir/!! if $input_dir;
    $this->page_name($page_name);
  }

  #vpath = current local dir + includepath
  my $vpath = [ @{$this->{includepath}} ];
  my $local_dir = "";
  if ($this->{parent_parser}) {
    if ($this->{parent_parser}->{current_fname} =~ m!^(.*)/[^/]+$!) {
      $local_dir = $1;
    }
  }
  unshift @$vpath, $local_dir;

  # find the candidate file to parse.
  my $fname;
  if ($path =~ m!^/!) {
    $fname = $path if -f $path and -r $path;
  } else {
    for my $try (map { $_ ? $_."/".$path : $path } @$vpath) {
      (-f $try and -r $try) or next;
      $fname = $try;
      last;
    }
  }

  my ($error_text,$ret);
  try {
    # throw exception if we don't have a filename.
    $fname or die "could not locate '$path'\n";
    $this->{current_fname} = $fname;

    # collect dependency information.
    $this->{depends} and
      push @{$this->{depends}}, $fname unless $this->{depends_h}->{$fname}++;

    #Get the numbr of levels to know how many stars to print.
    my $n_lvls = 0;
    for ( my $p=$this;$p; $p=$p->{parent_parser} ) { $n_lvls++ };

    # Begin the page code for this file.
    $this->code("###".("#" x $n_lvls)." begin parse of $fname\n");
    $this->code_indent("  ");

    # Allow parser to be in an initial error state.
    my $prev_n_errors = $this->{n_errors} || 0;

    # Parse the file.
    $ret = $this->SUPER::parse_file($fname) or
      die "parse_file $fname: failed: $!\n";

    # Clean up the page code for this file.
    $this->code_indent("");
    $this->code("###".("#" x $n_lvls)." end parse of $fname\n");

    # Detect any new errors.
    undef $ret if ($this->{n_errors}||0) > $prev_n_errors;

  } catch Error::Simple with {
    my ($e) = @_;
    $error_text = $e->text();
    undef $ret;
  };

  # restore the parser to its previous state.
  $orig_incpath and $this->{includepath} = $orig_incpath;

  return ($ret,$error_text) if wantarray;
  return $ret;
}

=head2 parse_uri

 instance
 () parse_uri (string $page,string \@incpath)

DESCRIPTION:

Called to parse files. C<$page> should be the file location.

=cut

sub parse_uri {
  my ($this, $path, $incpath) = @_;
  $this->debug_line($path);

  # convert absolute paths here to relative paths.
  $path =~ s/^\.?\/+//o;
  # assign the page_name before it is recombined with incpath.
  $this->page_name($path);

  my @rets = $this->parse_file($path,$incpath);

  return @rets if wantarray;
  return $rets[0];
}

=head2 include_file

 [private] instance
 () include_file (string $src)

DESCRIPTION:

See PSP specification.

This function will start a new parser of its own and hand the specified
file off to it.  The file will be searched for in the following paths:

 1) current directory of parent parser.
 2) directories specified on command line via -I argument.

=cut

sub include_file {
  my ($this, $src) = @_;

  #flush the parent parser.
  $this->flush();

  #create and pass along the fieldspace and state
  my $subparser = $this->new();
  $subparser->propagate_state_from($this);
  $subparser->{parent_parser} = $this;

  #parse included file
  my ($found_name,$throw_text) = $subparser->parse_uri($src);

  #get state from subparser back into super-parser.
  #recover as much as possible on error.
  delete $subparser->{parent_parser};
  $this->propagate_state_from($subparser);

  #throw here if we have throw_text
  $throw_text and throw Error::Simple($throw_text);
}

sub context {
  my ($this) = @_;
  return $this->{stack_context}->[-1];
}

sub prev_context {
  my ($this) = @_;
  return $this->{prev_context};
}

sub pop_context {
  my ($this) = @_;
  $this->debug_line(scalar(@{$this->{stack_context}}));
  if (@{$this->{stack_context}} > 1) {
    $this->{prev_context} = $this->context();
    return pop @{$this->{stack_context}};
  }
}

sub push_context {
  my ($this,$context) = @_;
  $this->debug_line(@{$this->{stack_context}}." + $context");
  if ($context) {
    $this->{prev_context} = $this->context();    
    return push @{$this->{stack_context}}, $context;
  }
}

sub propagate_state_from {
  my ($this,$from,@to_propagate) = @_;
  @to_propagate or @to_propagate = @{$this->{propagatable}};
#print "called with ".join(",",@to_propagate)."\n";
  my @propagated;
#print "===================================FROM:\n".dump_object($from);
  for my $state (@to_propagate) {
    exists $from->{$state} or next;
    $this->{$state} = $from->{$state};
    push @propagated, $state;
  }
#print "===================================AFTER:\n".dump_object($this);
  return @propagated;
}

sub reformat_tag {
  my ($this,$tag,$attr_in,@order) = @_;
  my $attr = { %$attr_in };

  # reconstruct and output the form tag.
  my $form_tag = "<".$tag;
  for my $a (@order) {
    $attr->{$a} or next;
    $form_tag .= " $a=\"$attr->{$a}\"";
    delete $attr->{$a};
  }
  %$attr and $form_tag .= " ".
    join(" ",map {"$_=\"$attr->{$_}\""} sort keys %$attr);
  $form_tag .= ">";
}

=head2 check_integrity

 [private] instance
 () check_integrity  (string $tag)

DESCRIPTION:

Look for post-parse error states.

=cut

sub check_integrity {
  my ($this) = @_;
  my $n_errors = 0;

  if (@{$this->{stack_text_sub}} > 1) {
    $this->log_exception("Extra text handlers found in stack_text_sub.");
    $n_errors++;
  }
  if (@{$this->{stack_code_sub}} > 1) {
    $this->log_exception("Extra code handlers found in stack_code_sub.");
    $n_errors++;
  }
  if (@{$this->{stack_decl}} > 1) {
    $this->log_exception("Extra declaration strings in stack_decl");
    $n_errors++;
  }
  if (@{$this->{stack_context}} > 1) {
    $this->log_exception("Extra context identifiers in stack_context");
    $n_errors++;
  }
  if (@{$this->{stack_handlers}} > 1) {
    $this->log_exception("Extra set(s) of handlers in stack_handlers");
    $n_errors++;
  }

  return $n_errors;
}

# called when a PSP::Parser object becomes aware of this functionality.
sub register {
  my ($this,$pkg) = @_;

  no strict 'refs';
  for my $handled (@{$pkg."::handled"}) {
    $this->{handlers_begin}->{"psp:$handled"} = \&{$pkg."::begin_psp$handled"};
    $this->{handlers_end}->{"psp:$handled"} = \&{$pkg."::end_psp$handled"};
  }
  for my $handled (@{$pkg."::handled_no_end"}) {
    $this->{handlers_begin}->{"psp:$handled"} = \&{$pkg."::begin_psp$handled"};
  }

  map { $this->{"stack_$_"}   = [] } @{$pkg."::stacks"};
  map { $this->{"current_$_"} = "" } @{$pkg."::current"};

  for my $prop (@{$pkg."::propagatable"}) {
    (grep { $_ eq $prop } @{$this->{propagatable}}) or
      push @{$this->{propagatable}}, $prop;
  }

  $this->{fieldspaces} = {} unless $this->{fieldspaces};
  $this->{verify_code} ||= "";
}

# called when the PSP::Parser needs to handle more tags.
sub register_tags {
  my ($this,$pkg,$tags) = @_;
  no strict;
  $pkg and $pkg .= "::";
  for my $tag (sort keys %$tags) {
    $this->{handlers_begin}->{$tag} = \&{$pkg."begin_".$tags->{$tag}};
    $this->{handlers_end}->{$tag}   = \&{$pkg."end_".$tags->{$tag}};
  }
  use strict;
}

# called when the PSP::Parser needs to handle more tags.
sub unregister_tags {
  my ($this,$tags) = @_;
  no strict;
  for my $tag (sort keys %$tags) {
    delete $this->{handlers_begin}->{$tag};
    delete $this->{handlers_end}->{$tag};
  }
  use strict;
}

1;
__END__

=head1 BUGS

No known bugs, but this does not mean no bugs exist.

=head1 SEE ALSO

L<HTML::Parser>, L<HTMLIO::Utils>

=head1 COPYRIGHT

 PSP - Perl Server Pages
 Copyright (c) 2000, FundsXpress Financial Network, Inc.

 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2 of the License, or (at your option) any later version.

 BECAUSE THIS LIBRARY IS LICENSED FREE OF CHARGE, THIS LIBRARY IS
 BEING PROVIDED "AS IS WITH ALL FAULTS," WITHOUT ANY WARRANTIES
 OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, WITHOUT
 LIMITATION, ANY IMPLIED WARRANTIES OF TITLE, NONINFRINGEMENT,
 MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE, AND THE
 ENTIRE RISK AS TO SATISFACTORY QUALITY, PERFORMANCE, ACCURACY,
 AND EFFORT IS WITH THE YOU.  See the GNU Lesser General Public
 License for more details.

 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA

=cut