sub validate($$){
    my($self,$name) = @_;

    if(! defined($self->{params}->{$name}) ){
        return $self->setError("'$name' was not given.");
    }

    my $value = $self->{params}->{$name} || 
            $self->{params}->{retvals}->{$name};
            

    my $field = $self->getField($name);
    my $allowed = $field->{allowed};
    my $comment = $field->{comment};
    my $escape  = $field->{escape} || "yes"; 

    if($value =~ /^$allowed$/){
       return (($escape eq "no") ? $value : quotemeta($value));
    }elsif(! $allowed){
       return $self->setError("No constraints defined for '$name'");
    }else{
       return $self->setError("Forbidden characters in $name: '".
         quotemeta($value)."' ". ($comment ? "($comment)" : ""));
    }
}



##</code><code>##


# WebForm.pm - Part of the 'WebForm' package.

$VERSION = '0.18-4';

package WebForm;

# This module converts xml files into hashes, 
# quite useful for this module.

BEGIN {
	require XML::Simple;
	if($@){
	    die("You dont have XML::Simple (libxml-simple-perl) installed!\n".
		"Download it from http://www.web.co.nz/~grantm/cpan/\n\n");
	}
	import XML::Simple;
}

# We use this module for OO-like error reporting.
use Carp;

# By Pre-defining the fields we get an idea of how
# this object looks like.
my %fields = (
	debug		=> 0,
	source		=> undef,
	error		=> []
);

=head1 NAME

WebForm - Rapid (Webbased) Application Development 

=over 4

=cut

=head1 SYNOPSIS

 use WebForm;

 <do something that fills %params>

 my $form = new WebForm(Source => './my.form');

 if($form->process(%params)){
	print("Form Processed!\n");
 }else{
	print("Oops! Form process failed: ". $form->error())."\n");
 }


=cut

=head1 DESCRIPTION

To make use of this module you'll need to create an XML document
containing form definitions. See the 'examples' directory that 
ships with this package.
An overview of the fileformat can be viewed in the textfile 'FORMS'

The following methods are available:


=item I<new(%options)>

  WebForm::new()

 Description:		The main contructor for this class to
			provide OO-like access.
 Arguments:		Source: Source .XML Form definitions file
			Debug:  Toggle Debugging mode (0 or 1)

=cut


sub new {
	my $that  = shift;
        my $class = ref($that) || $that;
        my $self  = {
            _permitted => \%fields,
            %fields,
        };
	bless($self);
	my %opts = @_;

	if($opts{'Source'}){
		$self->{source} = $opts{'Source'};
	}else{
		$self->{error}="'Source' must be given to WebForm::new()";
		return undef; 
	}
	$self->{debug}  = $opts{'Debug'};

	return $self;
}

=item I<debug([debug_value])>

  WebForm::debug()

 Description:		This function prints out data as debugging information
 Arguments:		A line containing the debugging message and,
 			A string 'source' where the data comes from.

=cut

sub debug{
	my($self,$line, $source) = @_;
	if($self->{debug}){
		print STDERR ($source || "WebForm") .": ". $line."\n";
	}
}

=item I<error()>

  WebForm::error()

 Description:		Returns a string containing the current 
			errors that have occured.
 Arguments:		None
  Note that the errors are concatenated using '$"' (See perlvar(1))

=cut

sub error{
	my $self = shift;
	$" = ", " if not defined($");
	return join($",@{$self->{error}});
}

=item I<errors()>

  WebForm::error()

 Description:		Returns an array containing the current 
			errors that have occured.
 Arguments:		None

=cut

sub errors{
	my $self = shift;
	return @{$self->{error}};
}

#===============================================================================
#  WebForm::setError()
#
# Description:		Adds an error message to the error-list
#
# Arguments:		A Scalar containing the error  message
#
#===============================================================================
sub setError{
	my ($self,$error) = @_;
	push(@{$self->{error}}, $error);
	return;
}

#===============================================================================
#  WebForm::parseForms()
#
# Description:		Parses the forms and initializes the XML object.
#
# Arguments:		None
#
#===============================================================================
sub parseForms{
	my($self) = shift;
	$self->debug("Parsing Forms from '".$self->{source}."'");

	my $xs = new XML::Simple( forcearray => 1, 
					parseropts => [ KeepCDATA => 1]
	);

	return $xs->XMLin($self->{source});
	# return XMLin($self->{source}, forcearray => 1);
}

#===============================================================================
#  WebForm::validate()
#
# Description:		Validates the given variable using the pre-defined
#			constraints.
#
# Arguments:		One scalar containg the name of the variable
#
#===============================================================================
sub validate($$){
	my($self,$name) = @_;

	if(! defined($self->{params}->{$name}) ){
		return $self->setError("'$name' was not given.");
	}

	my $value = $self->{params}->{$name} || 
		    $self->{params}->{retvals}->{$name};
		    

	my $field = $self->getField($name);
	my $allowed = $field->{allowed};
	my $comment = $field->{comment};
	my $escape  = $field->{escape} || "yes"; 

	if($value =~ /^$allowed$/){
	   return (($escape eq "no") ? $value : quotemeta($value));
	}elsif(! $allowed){
	   return $self->setError("No constraints defined for '$name'");
	}else{
	   return $self->setError("Forbidden characters in $name: '".
		 quotemeta($value)."' ". ($comment ? "($comment)" : ""));
	}
}

#===============================================================================
#  WebForm::getField()
#
# Description:		Retrieves the field entry for the given variable
#
# Arguments:		One scalar containing the variable name
#
#===============================================================================
sub getField{
	my ($self,$name) = @_;
	my @fields = @{$self->{forms}->{Fields}};
	foreach my $f(@fields){
		foreach my $type(keys(%{$f})){
			if($f->{$type}->{$name}){
				return $f->{$type}->{$name};
			}
		}
	}
	return undef;
}

#===============================================================================
#  WebForm::performAction()
#
# Description:		Performs the actions specified in the document.
#			Is usually called after the data has been validated.
#
# Arguments:		None
#
#===============================================================================
sub performAction($$){
	my($self) = @_;

	my %options = %{$self->{forms}->{option}};

	my $action = $self->{params}->{action} 
	 || $self->{forms}->{defaultaction} 
	 || return setError("No action given (And no default action found)");
	$self->debug("Performing ". ($self->{params}->{action}  
			|| $self->{forms}->{defaultaction}." (default)") 
	);

	my %actions = %{$self->{forms}->{Action}};
	if(! $actions{$action} ){
		return $self->setError("No Such Action: '$action'");
	}
	# Override with local options:
	foreach my $opt(keys(%{$actions{$action}->{option}})){
		$options{$opt} = $actions{$action}->{option}->{$opt};
		$self->debug("Option: $opt => ".
			$actions{$action}->{option}->{$opt}->{value});

		if( ($opt =~ /autoupdate/i) ){
			$self->{AutoUpdate} = $options{$opt}->{value};
		}
	}
	my $output = $self->createOutput($options{'Output'}->{value});

	foreach my $code(@{$actions{$action}->{code}}){
		my $lang = $code->{language} or 
			return $self->setError("No Language for this action!");

		my $content = $self->replaceVars($code->{content}) or return;

		my $variable = $code->{variable};
		my $data = $self->executeLanguage($lang,
						  $content,
						  $variable,
						  %options
		);

		if($variable){
			my $o = $self->updateOutput($output, $variable,
						    \%options, $data );
			$output = $o;
		}

		if($self->error()){
			$self->debug("There are errors, stopping action.");
			last;
		}
	}
	if($output){
		$self->printOutput($output);
	}

	if($options{'nextaction'}->{value}){
		$self->debug("Going to next action: ".
			$options{'nextaction'}->{value});
		$self->{params}->{action} = $options{'nextaction'}->{value};
		return $self->performAction();
	}else{
		return "ok";
	}

}

#===============================================================================
#  WebForm::executeLanguage()
#
# Description:		Adds an error message to the error-list
#
# Arguments:		A Scalar containing the error  message
#
#===============================================================================
sub executeLanguage{
	my($self,$language,$code,$variable,%options) = @_;

	$self->debug("Executing language '$language'..");

	eval "use WebForm::Language::".$language;
	if($@){ 
	  return $self->setError("Language '$language' is unsupported! ($@)");
	} 

	if($variable){
		my $data = eval { 
		  &{ "WebForm::Language::".$language."::execute" }
				  ($self,$code,$variable,%options); 
		};
		if($@){
			return $self->setError("WebForm::Language::".$language.
				"::execute() failed: $@");
		}
		$self->{retvals}->{$variable} = $data;
		return($data);
	}else{
		eval { 
		 &{ "WebForm::Language::".$language."::execute" }
		 	($self,$code,$variable,%options); 
		};
	}	

	if($@){ 
	  $self->setError("WebForm::Language::".$language.
	  		  "::execute() error: $@"); 
	}
}

#===============================================================================
#  WebForm::createOutput()
#
# Description:		Creates an output-filter for this action.
#
# Arguments:		The name of the outputfilter. (=package name)
#
#===============================================================================
sub createOutput{
	my($self,$outputfilter) = @_;
	if (! $outputfilter  ){
		return $outputfilter;
	}
	my $output = "";
	$self->debug("Creating outputfilter..");
	eval "use WebForm::Output::".$outputfilter;
	if($@){ croak("Output Filter '$outputfilter' is unsupported! ($@)");} 

	my $str = '$output = new WebForm::Output::'.$outputfilter;
	eval($str);
	
	if($@){ croak("Output Object creation failed: $@ ($str)");} 
	$self->debug("Outputfilter Created..");
	return $output;
}

#===============================================================================
#  WebForm::updateOutput()
#
# Description:		Sends code-results to the initialized outputfilter.
#
# Arguments:		4 arguments:
#			 1: Outputfilter object.
#			 2: Variable name for this data
#		 	 3: Options hash for this action/form
#			 4: Output Array of the code block.
#
#
#===============================================================================
sub updateOutput{
	my($self,$outputfilter,$variable,$o,$data) 	= @_;

	my(%options)	= %{$o};

	if(! $self->autoUpdate()){ # forgetting '!' here is *deadly*
		$self->debug("Queueing output for '".
				$outputfilter .
			     "' ('$variable' => '$data')");
		$self->{output_queue}->{$variable}->{params} = \@_;
		$self->{output_queue}->{$variable}->{data} = $data;
		return $outputfilter;
	}
	if(! $outputfilter ){
		return undef;
	}
	
	$self->debug("Updating output for '".$outputfilter->toString()."'".
			"($variable: [$data=|".$data."|])");
	my %dat = ( "$variable" => $data );

	$outputfilter->update(\%options,\%dat);

	if($@){ 
		$self->setError("WebForm::Output::".$outputfilter->toString().
				"::update() error: $@"); 
	}
	return $outputfilter;
}
sub autoUpdate{
	my($self) = shift;
	my $a = $self->{AutoUpdate};
	if($a && ($a eq "false" || $a eq "no")){
		return undef;
	}else{
		return "true";
	}
}

#===============================================================================
#  WebForm::printOutput()
#
# Description:		Calls the output() method on the given outputfilter
#
# Arguments:		The outputfilter object
#
#===============================================================================
sub printOutput{
	my($self,$output) = @_;

	if(! $self->autoUpdate()){
		$self->{AutoUpdate} = "yes"; # Overwrite it so updateOutput()
					     # doesnt queue it again :)
		$self->debug("printOutput() - Flushing queued items) ");
		foreach my $var( keys( %{ $self->{output_queue} }) ){
		  my @params = @{ $self->{output_queue}->{$var}->{params} };

		  # Sync in case any changes has been made
		  # TODO: Replace this by functions
		  $params[4]  = $self->{output_queue}->{$var}->{data};

		  updateOutput( @params );
		}
	}
	$self->debug("Outputting using plugin '".$output->toString()."'.");
	$output->output();
	if($@){ 
	 $self->setError("WebForm::Output::".$output."::output() error: $@"); 
	}
}

=item I<process(%param)>

  WebForm::process()

 Description:		Processes the form (ie "Fire-it-up!")
 			using the given parameters.

 Arguments:		One hash containing *all* parameters in the 
			following format:
			{ <key1> => <value>, <key2> => <value> }

			(like CGI::Vars() returns)

=cut

sub process($$){
	my($self,%params) = @_;
	$self->{params} = \%params;
	$self->{forms} = $self->parseForms();

	return ( $self->performAction() && (! $self->error()) );
}

sub getVar($$){
	my($self, $variable) = @_;

	return $self->{params}->{$variable};
}
sub setVar($$$){
	my($self, $variable, $value) = @_;
	$self->{params}->{$variable} = $value;
}

#===============================================================================
#  WebForm::replaceVars()
#
# Description:		Replaces all '${Name}' variables by its value
#
# Arguments:		String that needs to be replaced
#
#===============================================================================
sub replaceVars($$){
	my($self,$code) = @_;
	my @tokens = ($code =~ /\$\{(\S+?)\}/g);
	foreach my $var(@tokens){
		my $value = $self->validate($var);
		if(defined($value)){
			my $text = quotemeta('${'.$var.'}');
			$code =~ s/$text/$value/g;
		}
	}
	if($code =~ /(\$\{\S+\})/){
		return undef;
	}
	return $code;
}

=back

=head1 SEE ALSO

L<Site_db>, L<HTML::Template>, L<XML::Simple>

=head1 ABOUT

This module was written by Pieter Jansen to speed up and
improve the development of webbased applications such as customer database 
management systems, issue tracking systems etc. 

Due to it's pluggable nature you can enhance by writing your own plugins
to your needs. 

The core aim for this module is to minimize the amount of code duplication
in projects (ie: user-data verification algorithms) and to maximize the
security of your applications by providing strong data-verification 
algorithms.

=head1 COPYRIGHT

WebForm.pm version 0.16, Copyright (C) 2000 Pieter Jansen <wf@html-editor.org>

WebForm.pm comes with ABSOLUTELY NO WARRANTY; for details view Copying.
This is free software, and you are welcome to redistribute it
under certain conditions; view Copying for details.

=cut