File Coverage

blib/lib/CGI/EZForm.pm

Criterion	Covered	Total	%
statement	134	188	71.2
branch	45	80	56.2
condition	29	77	37.6
subroutine	19	26	73.0
pod	15	15	100.0
total	242	386	62.6

package CGI::EZForm;

# Pod-style documentation is at the end of this file.

use Carp qw(carp croak);

use Exporter();
@ISA = Exporter;

$CGI::EZForm::VERSION = "2002.0403";
sub Version { $VERSION; }

%default = (

    # field receive defaults
    multivalue_sep => ';',	# separator for multiple values of a field

    # table formatting defaults
    table => 1,			# draw fields within a table
    table_border => 0,		# table border is invisible
    table_width  => '80%',	# table is 80% of window wide
    table_align  => 'center',	# table is centered
    cellspacing  => 0,
    cellpadding  => 10,
    label_width  => '20%',	# label column is 20% of table width
    label_align  => 'right',	# label alignment
    td_valign    => 'top',		# table cell vertical alignment

    # field defaults
    type => 'text',		# default field type is text
    size => 30,			# default text/textarea width is 30 chars
    checkbox => 'Y',		# default value for checkbox
    rows => 3,			# default textarea rows

    # form header defaults
    method  => 'POST',
    enctype => 'application/x-www-form-urlencoded'
);

sub default {
    # change default value(s) to those specified
    my ($form) = shift;
    my %params = @_;
    foreach my $key (keys %params) {
        $default{$key} = $params{$key};
    }
}

sub new { return bless {}; }

sub set {
    # set one or more form values
    my $form   = shift;
    my %params = @_;
    foreach my $key (keys %params) {
        $form->{$key} = $params{$key};
    }
}

sub clear {
    # clear (delete) all form fields, or just those named in parameters
    my $form = shift;
    my @keys;
    my $key;
    if (@_ == 0) { # no params -- clear all
        @keys = keys(%$form);
    } else {
        @keys = @_;
    }
    foreach $key (@keys) {
	delete $form->{$key};
    }
}

sub get {
    my $form = shift;
    my $key = shift;
    return ($form->{$key} ? $form->{$key} : undef);
}

sub receive {
    my $form = shift;

    if (defined $ENV{'CONTENT_TYPE'}
    and $ENV{'CONTENT_TYPE'} =~ m#multipart/form-data#) {
	&_parse_multipart($form, &_receive());
    } else {
	&_parse_regular($form, &_receive());
    }
}

sub _receive {
    my ($incoming);

    # get the form data ...

    if (defined $ENV{'REQUEST_METHOD'} and $ENV{'REQUEST_METHOD'} eq "POST") {
        read(STDIN, $incoming, $ENV{'CONTENT_LENGTH'});
    }
    elsif (defined $ENV{'REQUEST_METHOD'} and $ENV{'REQUEST_METHOD'} eq "GET") {
        $incoming = $ENV{'QUERY_STRING'};
    }
    else { # for testing, allow input from command line
        $incoming = join('&',@ARGV);
    }

    return $incoming;
}

sub _parse_regular {
    my ($form, $incoming) = @_;

    # ... and decode it into %FORM

    my @pairs = split(/&/, $incoming);

    foreach (@pairs) {
        my ($name, $value) = split(/=/, $_);

	# un-escape any characters 'escaped' for http
        $name  =~ tr/+/ /;
        $value =~ tr/+/ /;
        $name  =~ s/%([A-F0-9][A-F0-9])/chr(hex($1))/gie;
        $value =~ s/%([A-F0-9][A-F0-9])/chr(hex($1))/gie;

        # Skip blank text entry fields
        next if ($value eq "");

        # Check for "assign-dynamic" field names
        # Mainly for on-the-fly input names, especially checkboxes
        if ($name =~ /^assign-dynamic/) {
            $name = $value;
            $value = "on";
        }

	# Allow for multiple values of a single name
	if (defined $form->{$name}) {
	    $form->{$name} .= $default{multivalue_sep};
	    $form->{$name} .= $value;
	} else {
	    $form->{$name} = $value;
	}
    }
}

sub _parse_multipart {
    croak 'Sorry, cannot deal with multipart forms yet.';
}

sub dump {
    my $form = shift;
    my @keys;
    my $key;
    if (@_ == 0) {
        @keys = sort keys(%$form);
    } else {
        @keys = @_;
    }
    foreach $key (@keys) {
       print $key, '=', $form->{$key}, "\n";
    }
}

sub use_table {
    my $form = shift;	# actually ignored for this function
    my $thing = shift;
    $default{table} = $thing;
}

sub draw {
    # draws a form input field or button
    my $form = shift;
    my %params = @_;
    my @keys = keys %params;
    my $key;
    my $html = '';

    # make sure anything required exists
    unless (defined $params{type}) {$params{type} = $default{type};}
    unless (defined $params{label}) {$params{label} = ' ';}

    # name is optional, but if not specified will assign the value as
    # a name when the data is received.
    unless (defined $params{name}) {$params{name} = 'assign-dynamic';}

    # provide for a label;
    # if we're  doing table formatting, this means putting it into
    # column one
    unless ($params{type} eq 'hidden') {
	if ($default{table}) {
	    $html .= _tr_start($params{label});
	} else {
	    $html .= $params{label};
	}
    }

    TYPE_CASE: {
        if ($params{type} eq 'select') {
	    $html .= qq|
	    $html .= qq| name="$params{name}"| if $params{name};
	    $html .= qq| multiple| if $params{multiple};
	    $html .= &_add_extras(\%params,
		grep !/^(type|label|name|multiple|options|values|selected)$/,
		     (keys %params));
	    $html .= qq|>\n|;
	    $html .= &_select(
		$params{options},
		$params{'values'},
		($params{selected} or [($form->{$params{name}} or '')])
		);
	    $html .= qq|\n|;
	    last;
	}

        if ($params{type} =~ /submit|reset|image/) {
	    $html .= "
	    $html .= &_add_extras(\%params,
		grep !/^(type|label)$/, (keys %params));
	    $html .= ">\n";
	    last;
	}

        if ($params{type} eq 'radio') {
	    $html .= &_radio(
		$params{name},
		($form->{$params{name}} or ''),
		($params{vertical} or 0),
		$params{captions}, $params{'values'});
	    last;
	}

        if ($params{type} eq 'checkbox') {
	    # checkbox gotta have value
	    unless (exists $params{value}) {
		if (defined $form->{$params{name}}) {
		    $params{value} = $form->{$params{name}};
		} else {
		    $params{value} = $default{checkbox};
		}
	    }
	    $html .= sprintf qq|
		$params{name},
		$params{value};
	    if (defined $form->{$params{name}}
	    and ($params{value} eq $form->{$params{name}}) ) {
		$html .= ' checked';
	    }
	    $html .= &_add_extras(\%params,
		grep !/^(type|label|name|value|caption)$/, (keys %params));
	    $html .= ">\n";
	    $html .= ($params{caption} or '');
	    last;
	}

        if ($params{type} eq 'textarea') {
	    $html .= sprintf
		qq|</tr>

<tr>
<td  class="h" >
<a name="258">258</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 		$params{name}, </td>
</tr>

<tr>
<td  class="h" >
<a name="259">259</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 		($params{rows} || $default{rows}), </td>
</tr>

<tr>
<td  class="h" >
<a name="260">260</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 		($params{cols} || $default{size}), </td>
</tr>

<tr>
<td  class="h" >
<a name="261">261</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 		($params{wrap} || 'virtual'); </td>
</tr>

<tr>
<td  class="h" >
<a name="262">262</a>
</td>

<td  class="c0" >

0

</td>

<td  class="c0" >
 <a href="blib-lib-CGI-EZForm-pm--branch.html#262-1"> 
  0
 </a> 
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

0

</td>

<td class="s"> 	    $html .= ' readonly' if $params{readonly}; </td>
</tr>

<tr>
<td  class="h" >
<a name="263">263</a>
</td>

<td  class="c0" >

0

</td>

<td  class="c0" >
 <a href="blib-lib-CGI-EZForm-pm--branch.html#263-1"> 
  0
 </a> 
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

0

</td>

<td class="s"> 	    $html .= ' disabled' if $params{disabled}; </td>
</tr>

<tr>
<td  class="h" >
<a name="264">264</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

0

</td>

<td class="s"> 	    $html .= &_add_extras(\%params, </td>
</tr>

<tr>
<td  class="h" >
<a name="265">265</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	     grep !/^(type|label|name|value|cols|rows|wrap|readonly|disabled)$/, </td>
</tr>

<tr>
<td  class="h" >
<a name="266">266</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s"> 	      (keys %params)); </td>
</tr>

<tr>
<td  class="h" >
<a name="267">267</a>
</td>

<td  class="c0" >

0

</td>

<td >

 

</td>

<td  class="c0" >
 <a href="blib-lib-CGI-EZForm-pm--condition.html#267-1"> 
  0
 </a> 
</td>

<td >

 

</td>

<td >

 

</td>

<td >

0

</td>

<td class="s"> 	    $html .= sprintf qq|>\n%s\n|,
		($params{value} or $form->{$params{name}} or '');
	    last;
	}

        if ($params{type} eq 'hidden') {
	    $html .= sprintf qq|\n|,
		$params{name},
		($params{value} || $form->{$params{name}});
	    last;
	}

	# default case is an input field (text or password)
	$html .= sprintf qq|
	    ($params{type} or $default{type}),
	    $params{name},
	    ($params{size} || $default{size}),
	    ($params{value} or $form->{$params{name}} or '');
	$html .= ' readonly' if $params{readonly};
	$html .= ' disabled' if $params{disabled};
	$html .= &_add_extras(\%params,
	    grep !/^(type|label|name|size|value|readonly|disabled)$/,
		(keys %params));
	$html .= ">\n";
    }
    unless ($params{type} eq 'hidden') {
	if ($default{table}) {
	    $html .= &_tr_end;
	}
    }
    return $html;
}

sub _select {
    my ($options, $values, $selected) = @_;
    my ($i, $count);

    my $html = '';

    $count = @$options;
    for ($i = 0; $i < $count; $i++) {
	$html .= &_option($$options[$i],
	    (defined $values ? $$values[$i] : ''),
	    @$selected);
    }

    return $html;
}

sub _option {
    my ($option, $value, @selected) = @_;
    my $html = '';
    $html .= qq|
    $html .= qq| value="$value"| if defined $value;
    # the option should be selected if it matches a list of options to
    # be selected
    if ( (defined $value and (grep /$value/, @selected))
    or   (defined $option and (grep /$option/, @selected)) ) {
	$html .= qq| selected|
    }
    $html .= qq|>$option\n|;
}

sub _radio {
    my ($name, $selected, $vertical, $captions, $values) = @_;
    my ($i, $count);

    my $html = '';

    $count = @$captions;
    for ($i = 0; $i < $count; $i++) {
	$html .= qq|
	$html .= qq| value="$$values[$i]"| if defined $values;
	$html .= qq| checked|
	    if (defined $selected and ($selected eq $$values[$i]));
	$html .= qq|>$$captions[$i]|;
	if ($vertical) {
	$html .= "\n"; } else { $html .= " \n"; }
    }

    return $html;
}

sub _add_extras {
    # add attributes from a list of param keys
    # this usefully allows you to include any attributes you like,
    # such as javascript.
    # Less usefully, you can include attributes which are not valid,
    # so be careful.
    $params = shift;	# hash ref.
    my $html = '';
    foreach my $key (@_) {
	$html .= qq| $key="$$params{$key}"|;
    }
    return $html;
}

sub hidden {
    my $form = shift;
    my @names = @_;
    my $html = '';
    foreach my $name (@names) {
	$html .= sprintf qq|\n|,
	    $name,
	    $form->{$name};
    }
    return $html;
}

sub form_start {
    my $form = shift;
    my %params = @_;

    my $html =
    sprintf qq|
	($params{action} || $ENV{SCRIPT_NAME}),
	($params{method} || $default{method}),
	($params{enctype} || $default{enctype});
	$html .= &_add_extras(\%params,
	    grep !/^(action|method|enctype)$/, (keys %params));
	$html .= ">\n";
    if ($default{table}) {
        $html .= &table_start();
    }
}


sub form_end {
    my $html = '';
    if ($default{table}) {
        $html .= &table_end();
    }
    $html .= "\n";
}

sub table_start {
    my $form = shift;
    my %params = @_;
    $default{table} = 1;
    return sprintf
	qq|\n|, 




408




 





 





 





 





 





 



 	($params{border} || $default{table_border}), 




409




 





 





 





 





 





 



 	($params{width} || $default{table_width}), 




410




 





 





 





 





 





 



 	($params{cellspacing} || $default{cellspacing}), 




411




 





 





 





 





 





 



 	($params{cellpadding} || $default{cellpadding}), 




412




 





 





 





 





 





 



 	($params{table_align} || $default{table_align}); 




413




 





 





 





 





 





 



 } 




414




 





 





 





 





 





 



   




415




 





 





 





 





 





 



 sub table_end { 




416




1





 





 




  
1
  



  
1
  




3



     $default{table} = 0; 




417




1





 





 





 





 





2



     return "\n";
	($params{border} || $default{table_border}),
	($params{width} || $default{table_width}),
	($params{cellspacing} || $default{cellspacing}),
	($params{cellpadding} || $default{cellpadding}),
	($params{table_align} || $default{table_align});
}

sub table_end {
    $default{table} = 0;
    return "
}


sub _tr_start {
    my ($label) = @_;
    $label = '' unless $label;
    return sprintf
	qq|
	$default{td_valign},
	$default{label_align},
	$default{label_width},
	$label,
	$default{td_valign};
}


sub _tr_end {
    # prints closing tags for a table row.
    return "
}

1;

__END__