package PSP::Parser::Form;

# 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: Form.pm,v 1.1.1.2 2003/12/06 19:47:26 hartmans Exp $

use strict;

=head1 NAME

 PSP::Parser::Form - Tag extension for form elements.

=head1 SYNOPSIS

=head1 DESCRIPTION

=cut

use Exporter;
use Error qw(:try);
use PSP::Utils;

BEGIN {
  @PSP::Parser::Form::ISA = qw(Exporter PSP::Parser);
  @PSP::Parser::Form::EXPORT_OK = qw(&dump_submits);
}

use vars qw(@handled @current @propagatable);
BEGIN {
  @handled = qw(form submit);
  @current = qw(form submit sname);
  @propagatable = ((map { "current_$_" } @current),
		   'forms','form_count');
};

=head1 TAG HANDLERS

=head2 form

 [private] instance
 () form ()

DESCRIPTION:

=cut

sub form {
  my ($this,$form_id) = @_;
  $form_id ||= $this->{current_form} or return;
  my $form = $this->{forms}->{$form_id} ||= {};
  $form->{form_id} ||= $form_id;
  return $form;
}

=head2 begin_pspform

 [private] instance () begin_pspform (string $tag, \%attrs, \@atrseq,
 string $orig)

DESCRIPTION:

See PSP specification.

=cut

sub begin_pspform {
  my ($this,$tag,$attr,$attr_seq,$orig_txt) = @_;
  $this->debug_line($orig_txt);

  # count == seed - initial seed == number of the form.
  $this->{form_count}++;
  my $form_id = $this->{seed}++;

  # check for nested forms.
  $this->{current_form} and throw
    Error::Simple("Nested forms are NOT allowed");

  $attr->{method} ||= "POST";

  # assign current form_id, acquire form hash, and map attributes into it.
  # and map certain input attributes into form hash.
  $this->{current_form} = $form_id;
  my $form = $this->{forms}->{$form_id} ||= { %$attr };

  # attempt to get the error_page from the form tag.
  delete $attr->{status};
  $form->{error_page} ||= delete $attr->{errorpage};

  # if there is a fieldspace attribute, do a virtual use_fieldspace tag.
  if ($attr->{fieldspace}) {
    if (! $this->can("begin_pspuse_fieldspace")) {
      $this->log_exception("fieldspace attribute ignored.");
    } else {
      $this->begin_pspuse_fieldspace($tag,$attr,$attr_seq,$orig_txt);
    }
  }

  # if we didn't get an error_page from the fieldspace nor the form tag ..
  $form->{error_page} ||= $this->page_name();

  $this->text($this->reformat_tag("form",$attr,qw(method action)));
}

=head2 end_form

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

DESCRIPTION:

See PSP specification.

=cut

sub end_pspform {
  my($this,$orig) = @_;

  my $form = $this->form() or throw 
    Error::Simple("<$orig> used outside of FORM context.");

  #close and flush the submits.
  #$this->{current_sname} and 
  #  $this->end_pspsubmit($orig);
  $this->flush_submit();

  # if there is a current fieldspace, close it.
  $this->can("fieldspace") and $this->fieldspace(0,1) and 
    $this->end_pspuse_fieldspace($orig);

  my $form_id = delete $this->{current_form};

  # if we had any submits, write out form_id.
  $form->{n_submits} and
    $this->text('<input type="hidden" name="_form_id" value="'.$form_id.'">');

  # write out this end-form-tag.
  $this->text("</form>\n");
}

=head2 begin_pspsubmit

 [private] instance
 () begin_pspsubmit (string $tag, \%attrs, \@atrseq, string $orig)

DESCRIPTION:

See PSP specification.

=cut

sub begin_pspsubmit {
  my ($this, $tag, $attr, $attr_seq, $orig_txt) = @_;

  $this->{current_sname} and throw
    Error::Simple("No nested SUBMIT allowed: ($this->{current_sname})");
  my $name = $attr->{name} || "";
  my $form = $this->form() or throw
    Error::Simple("<$tag> used outside of FORM context.");

  my $value = $attr->{value};
  my $rlike = $attr->{rlike};
  if (defined $rlike) {
    $rlike =~ s!/!\\/!g; 
    eval "/$rlike/"; $@ and throw
      Error::Simple("<$tag> contains invalid reg ex: /$rlike/: $@");
  }
  my $verify = $attr->{verify};
  my $sname = $name.(defined $value ? "=$value" : 
		     defined $rlike ? "=~/$rlike/" : "");
  $this->{current_sname} = $sname;
  $this->{current_submit} ||= "";

  if (exists $attr->{html}) {
    $this->text('<input type="submit" name="'.$name.'"'.
		' value="'.(defined $value ? $value : $name).'">');
  }

  my ($err_page,$goto,$status);

  $attr->{errorpage} and
    $err_page = quote_bareword(path_to_page_name($attr->{errorpage}));
  $attr->{goto} and
    $goto = quote_bareword(path_to_page_name($attr->{goto}));
  $attr->{status} and
    $status = quote_bareword($attr->{status});
  my $unconditional = bool_att($attr->{unconditional});

  my $cond = "";
  if ($name ne "") {
    $cond = "\$cgi->param('$name')";
    if (defined $rlike) {
      $cond .= " =~ /$rlike/";
    } elsif (defined $value) {
      $cond .= " eq '$value'";
    } else {
      $cond = "defined $cond and $cond ne ''"; 
    }
  }

  my @code;
  if (!$this->{current_submit}) {
    if ($cond ne "") {
      push @code, "  if ($cond) {";
    } else {
      push @code, "  if (1) {";
    }
  } else {
    if ($cond ne "") {
      push @code, "  elsif ($cond) {";
    } else {
      push @code, "  else {";
    }
  }

  push @code, "    \$err_page = $err_page;" if $err_page;
  push @code, "    \$status   = $status;"   if $status;
  push @code, "    \$goto     = $goto;"     if $goto;
  push @code, "    \$ignore_errors = 1;"    if $unconditional;

  map { $this->push_submit_code($_) } @code;

  if ($verify) {
    if ($verify eq "current") {
      if (! $this->can("begin_pspvcurrent")) {
	$this->log_exception("verify attribute used but not supported.");
      } else {
	$this->begin_pspvcurrent($tag,{});
      }
    } elsif ($verify eq "instantiated") {
      if (! $this->can("begin_pspvinstantiated")) {
	$this->log_exception("verify attribute used but not supported.");
      } else {
	$this->begin_pspvinstantiated($tag,{});
      }
    } else {
      $this->log_exception("verify attribute, '$verify' not supported.");
    }
  }
}

=head2 end_pspsubmit

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

DESCRIPTION:

See PSP specification.

=cut

sub end_pspsubmit {
  my ($this,$orig_txt) = @_;

  my $sname = delete $this->{current_sname}; defined $sname or throw
    Error::Simple("<$orig_txt> outside of SUBMIT context.");
  my $form = $this->form() or throw 
    Error::Simple("<$orig_txt> used outside of FORM context.");
  $form->{n_submits}++;

  if ($form->{was_ver}->{$sname}) {
    $this->push_submit_code('    $errors_to_check = 1;');
  }
  $this->push_submit_code('  }');
}

=head2 flush_submit

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

DESCRIPTION:

See PSP specification.

=cut

sub flush_submit {
  my ($this) = @_;

  my $form = $this->form() or throw
    Error::Simple("Internal error: flush_submit w/o FORM context.");

  # get (and remove) the current submit code from parser.
  #
  my $out = delete $this->{current_submit};

  $form->{submit} = $out;
}

=head2 dump_submits

 [private] instance
 () dump_submits (string @code)

DESCRIPTION:

This is called by the compiler to dump the submit info in the parser, and
return it to the caller.

=cut

sub dump_submits {
  my ($this,$submit_ids) = @_;

  my ($form,$submit_code,$fsname);
  my $out = "";

  for my $form_id (sort keys %{$this->{forms}}) {
    $form = $this->{forms}->{$form_id};
    $submit_code = $form->{submit} || "";
    # collapse whitespace in submit code.
    $submit_code =~ s/\s*(\n *\})/$1/sg;
    $fsname = $form->{fieldspace};

    my $err = quote_bareword(path_to_page_name($form->{error_page}));
    my $status = quote_bareword($form->{status});

    # begin this next submit sub.
    $out .= join("\n",
	(("#" x 78),
	 "sub submit__$form_id {",
	 '  my ($this,$goto) = @_;'
	))."\n";

    if (! $submit_code) {
      $out .= "  return \$goto;\n";
    } else {

      # if this form has a fieldspace, create it and initialize it.
      if ($fsname) {
	$out .= '  my $fs = $this->fieldspace("'.$fsname."\");\n";
      }

      # declare and/or initialize the submit environment.
      $out .= join("\n",
	("  my \$err_page = $err;",
	 "  my \$status   = $status;",
	 ))."\n\n";

      # these are variables the submit code may use or set..
      $out .= join("\n",
	('  my (%vfields,@errors,$err,%verifies,',
	 '     $errors_to_check,$ignore_errors,$_field,$_no_prop);',
	 '  my $cgi = $this->cgi();',
	))."\n\n";

      # add the accumulated submit code.
      $out .= $submit_code."\n";

      # if we have a fieldspace context, add error checking snippet.
      if ($fsname) {
	$out .= join("\n",
	('  if ($errors_to_check) {',
	 '    $fs->verify($cgi);',
	 '    if ($fs->errors_p() && !$ignore_errors) {',
	 '      $goto = $err_page;',
	 '    }',
	 '  }',
	 '  $fs->remove_verifies();'
	))."\n";
      }

    # finally add the goto statement.
      $out .= join("\n",
	('  my $loader = $this->loader();',
	 '  my ($pile,$page_name) = $loader->map_page($this,$goto);',
	 '  return ($page_name);',
	))."\n";
    }
    $out .= "}\n\n";
    push @$submit_ids, $form_id;
  }
  return $out;
}

=head2 push_submit_code

 [private] instance
 () push_submit_code (string @code)

DESCRIPTION:

Will add the C<@code> lines to the internal data structure
C<current_submit>.

=cut

sub push_submit_code {
  my($this) = shift;
  $this->{current_submit} .= join('',@_,"\n");
}

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