File Coverage

blib/lib/AxKit/XSP/PerForm.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

# $Id: PerForm.pm,v 1.24 2003/08/10 16:43:56 matt Exp $

package AxKit::XSP::PerForm;

$VERSION = "1.83";

use AxKit 1.4;
use Apache;
use Apache::AxKit::Language::XSP::TaglibHelper;
use AxKit::XSP::WebUtils 1.5;

$NS = 'http://axkit.org/NS/xsp/perform/v1';

@ISA = qw(Apache::AxKit::Language::XSP);

@EXPORT_TAGLIB = (
    'textfield($name;$default,$width,$maxlength,$index,$onvalidate,$onload,$disabled,$onchange)',
    'password($name;$default,$width,$maxlength,$index,$onvalidate,$onload,$disabled,$onchange)',
    'submit($name;$value,$image,$alt,$border,$align,$goto,$index,$onsubmit,$disabled,$onclick)',
    'cancel($name;$value,$image,$alt,$border,$align,$goto,$index,$oncancel,$disabled,$onclick)',
    'checkbox($name;$value,$checked,$label,$index,$onvalidate,$onload,$disabled,$onclick)',
    'file_upload($name;$value,$accept,$onvalidate,$onload,$disabled,$onclick)',
    'hidden($name;$value,$index,$onload)',
    'textarea($name;$cols,$rows,$wrap,$default,$index,$onvalidate,$onload,$disabled,$onchange)',
    'single_select($name;$default,$index,$onvalidate,$onload,$disabled,$onchange,*options):itemtag=option',
    'multi_select($name;@default,$index,$onvalidate,$onload,$disabled,$onclick,*option):itemtag=option',
);

use strict;

sub parse_char  {
    Apache::AxKit::Language::XSP::TaglibHelper::parse_char(@_);
}

sub parse_start {
    my ($e, $tag, %attribs) = @_;

    if ($tag eq 'form') {
        $e->manage_text(0);

        my $form_el = {
            Name => "form",
            NamespaceURI => "",
            Attributes => [
                { Name => "name", Value => $attribs{name} },
                { Name => "method", Value => "POST" },
                { Name => "enctype", Value => "multipart/form-data" },
            ],
        };
#MSS
#        if (Apache->args) {
#	    $form_el->{Attributes}[1]{Value} .='?'.Apache->args;
#        }
#end MSS

        $e->start_element($form_el);

        my $submitting = {
            Name => "hidden",
            NamespaceURI => "",
            Attributes => [
                { Name => "name", Value => "__submitting_$attribs{name}" },
                { Name => "value", Value => "1" },
            ],
        };
        $e->start_element($submitting);
        $e->end_element($submitting);

        return <
{
use vars qw(\$_form_ctxt \@_submit_buttons \%_submit_goto \%_submit_index \@_cancel_buttons \%_cancel_goto \%_cancel_index );
local \$_form_ctxt = { Form => \$cgi->parms, Apache => \$r, Name => '$attribs{name}' };
local \@_submit_buttons;
local \@_cancel_buttons;
local \%_submit_goto;
local \%_cancel_goto;
local \%_submit_index;
local \%_cancel_index;
start_form_$attribs{name}(\$_form_ctxt, \$cgi->param('__submitting_$attribs{name}'))
          if defined \&start_form_$attribs{name};
EOT
    }
    else {
        return Apache::AxKit::Language::XSP::TaglibHelper::parse_start(@_);
    }
}

sub end_element {
    my ($e, $element) = @_;

    if ($element->{Name} eq 'form') {
        my $form_el = {
            Name => "form",
            NamespaceURI => "",
            Attributes => [],
        };

        my $name;
        my $onsubmit;
        my $oncancel;
        my $onformend;

        for my $attr (@{$element->{Attributes}}) {
            if ($attr->{Name} eq 'name') {
                $name = $attr->{Value};
            }
            elsif ($attr->{Name} eq 'onformend') {
                $onformend = $attr->{Value};
            }
            elsif ($attr->{Name} eq 'onsubmit') {
                $onsubmit = $attr->{Value};
            }
            elsif ($attr->{Name} eq 'oncancel') {
                $oncancel = $attr->{Value};
            }
        }

        $e->end_element($form_el);
        return <
my \$package = __PACKAGE__;
if (my \$sub = \$package->can('$onformend' || 'end_form_$name')) {
    \$sub->(\$_form_ctxt, \$cgi->param('__submitting_$name'));
}

# warn("submitting? ".(\$cgi->param('__submitting_$name')?"yes":"no").", failed? ".(\$_form_ctxt->{_Failed}?"yes":"no"));

if (\$cgi->param('__submitting_$name')) {
    foreach my \$cancel (\@_cancel_buttons) {
        if (\$cgi->param(\$cancel)) {
            no strict 'refs';
            my \$redirect;
            \$redirect = \$_cancel_goto{\$cancel};
            if (my \$sub = \$package->can(\$_cancel_index{\$cancel}{oncancel} || '$oncancel' || "cancel_\$_cancel_index{\$cancel}{name}")) {
                \$redirect = \$sub->(\$_form_ctxt, \$_cancel_index{\$cancel}{'index'});
            }
            if (\$redirect) {
                return AxKit::XSP::WebUtils::redirect(\$redirect,undef,undef,1);
            }
        }
    }
}

if (\$cgi->param('__submitting_$name') && !\$_form_ctxt->{_Failed}) {
     foreach my \$submit (\@_submit_buttons) {
        if (\$cgi->param(\$submit)) {
            no strict 'refs';
            my \$redirect;
            \$redirect = \$_submit_goto{\$submit};
            if (my \$sub = \$package->can(\$_submit_index{\$submit}{onsubmit} || '$onsubmit' || "submit_\$_submit_index{\$submit}{name}")) {
                \$redirect = \$sub->(\$_form_ctxt, \$_submit_index{\$submit}{'index'});
            }
            if (\$redirect) {
                return AxKit::XSP::WebUtils::redirect(\$redirect,undef,undef,1);
            }
        }
    }
}

# catch the case where IE submitted the form without any buttons used
if (\$cgi->param('__submitting_$name') && !\$_form_ctxt->{_Failed}) {
    no strict 'refs';
    my \$redirect;
    if (my \$sub = \$package->can('$onsubmit')) {
        \$redirect = \$sub->(\$_form_ctxt);
    }
    if (\$redirect) {
        return AxKit::XSP::WebUtils::redirect(\$redirect, undef, undef, 1);
    }
}

}
EOT
    }
    else {
        return Apache::AxKit::Language::XSP::TaglibHelper::parse_end($e, $element->{Name});
    }
}

sub textfield ($;$$$$$$$$) {
    my ($name, $default, $width, $maxlength, $index, $onval, $onload,
        $disabled, $onchange) = @_;
    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};

    my $params = $ctxt->{Form};
    my $fname = $ctxt->{Name};

    my $error;

    # validate
    if ($params->{"__submitting_$fname"}) {
        # warn("Checking if $package can " . ($onval || "validate_${name}") . "\n");
        if (my $sub = $package->can($onval || "validate_${name}")) {
            eval {
                $sub->($ctxt, ($params->get($name.$index))[-1], $index);
                $params->{$name.$index} = ($params->get($name.$index))[-1];
            };
            $error = $@;
            $ctxt->{_Failed}++ if $error;
            $error =~ s/(.*) at .*? line \d+\.$/$1/;
        }
    }
    # load
    elsif (my $sub = $package->can($onload || "load_${name}")) {
        $params->{$name.$index} = $sub->($ctxt, $default, ($params->get($name.$index))[-1], $index);
    }
    else{
        $params->{$name.$index} = $default;
    }

    return {
        textfield => {
            width => $width,
            maxlength => $maxlength,
            name => $name,
            value => ($params->get($name.$index))[-1],
	    index => $index,
            ($disabled ? (disabled => $disabled) : ()),
            ($onchange ? (onchange => $onchange) : ()),
            ($error ? (error => $error) : ()),
            }
        };
}

sub submit ($;$$$$$$$$$$) {
    my ($name, $value, $image, $alt, $border, $align, $goto, $index,
        $onsubmit, $disabled, $onclick) = @_;
    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};
    my $params = $ctxt->{Form};

    push @{"${package}::_submit_buttons"}, "$name$index";
    ${"${package}::_submit_goto"}{$name.$index} = $goto if $goto;
    ${"${package}::_submit_index"}{$name.$index}{'index'} = $index;
    ${"${package}::_submit_index"}{$name.$index}{'name'} = $name;
    ${"${package}::_submit_index"}{$name.$index}{'onsubmit'} = $onsubmit;

    # save
    if ($image) {
        return {
            image_button => {
                name => $name,
                value => $value,
                src => $image,
                alt => $alt,
                border => $border || 0,
                align => $align || "bottom",
                ($disabled ? (disabled => $disabled) : ()),
                ($onclick ? (onclick => $onclick) : ()),
		index => $index,
            }
        };
    }
    else {
        return {
            submit_button => {
                name => $name,
                value => $value,
		index => $index,
                ($disabled ? (disabled => $disabled) : ()),
                ($onclick ? (onclick => $onclick) : ()),
            }
        };
    }
}

sub cancel ($;$$$$$$$$$$) {
    my ($name, $value, $image, $alt, $border, $align, $goto, $index,
        $oncancel, $disabled, $onclick) = @_;
    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};
    my $params = $ctxt->{Form};

    push @{"${package}::_cancel_buttons"}, $name.$index;
    ${"${package}::_cancel_goto"}{$name.$index} = $goto if $goto;
    ${"${package}::_cancel_index"}{$name.$index}{'index'} = $index;
    ${"${package}::_cancel_index"}{$name.$index}{'name'} = $name;
    ${"${package}::_cancel_index"}{$name.$index}{'oncancel'} = $oncancel;

    # save
    if ($image) {
        return {
            image_button => {
                name => $name,
                value => $value,
                src => $image,
                alt => $alt,
                border => $border || 0,
                align => $align || "bottom",
		index => $index,
                ($disabled ? (disabled => $disabled) : ()),
                ($onclick ? (onclick => $onclick) : ()),
            }
        };
    }
    else {
        return {
            submit_button => {
                name => $name,
                value => $value,
		index => $index,
                ($disabled ? (disabled => $disabled) : ()),
                ($onclick ? (onclick => $onclick) : ()),
            }
        };
    }
}

sub button ($;$$) {
    my ($name, $value, $index) = @_;

    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};
    my $params = $ctxt->{Form};

    # TODO: What do we want buttons to do?
}

sub checkbox ($;$$$$$$$$) {
    my ($name, $value, $checked, $label, $index, $onval, $onload,
        $disabled, $onclick) = @_;

    my ($package) = caller;
    $value = 1 unless $value;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};

    my $params = $ctxt->{Form};
    my $fname = $ctxt->{Name};

    my $error;

    # validate
    if ($params->{"__submitting_$fname"}) {
        if (my $sub = $package->can($onval || "validate_${name}")) {
            eval {
                $sub->($ctxt, ($params->get($name.$index))[-1], $index);
                $params->{$name.$index} = ($params->get($name.$index))[-1];
            };
            $error = $@;
            $ctxt->{_Failed}++ if $error;
            $error =~ s/(.*) at .*? line \d+\.$/$1/;
        }
    }
    # load
    elsif (my $sub = $package->can($onload || "load_${name}")) {
        my @vals = $sub->($ctxt, $value, ($params->get($name.$index))[-1], $index);
        $checked = shift @vals;
        $value = shift @vals if @vals;
    }
    else {
        $checked = 1 if defined(($params->get($name.$index))[-1]);
    }

    if ($checked && $checked eq 'yes') {
        $checked = 1;
    }
    elsif ($checked && $checked eq 'no') {
        $checked = 0;
    }

    return {
        checkbox => {
            name => $name,
            value => $value,
            ( $checked ? (checked => "checked") : () ),
            label => $label,
            ( $error ? (error => $error) : () ),
	    index => $index,
            ($disabled ? (disabled => $disabled) : ()),
            ($onclick ? (onclick => $onclick) : ()),
        }
    };
}

sub file_upload ($;$$$$$$) {
    my ($name, $value, $accept, $onval, $onload, $disabled, $onclick) = @_;
    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};

    my $params = $ctxt->{Form};
    my $fname = $ctxt->{Name};

    my $error;

    # validate
    if ($params->{"__submitting_$fname"}) {
        if (my $sub = $package->can($onval || "validate_${name}")) {
            my $upload = Apache::Request->instance(Apache->request)->upload($name);

            my $filename;
            if ($upload) {
                $filename = $upload->filename;
                $filename =~ s/.*[\\\/]//; # strip to just a filename
                $filename =~ s/[^\w\.-]//g; # strip non-word chars
            }

            eval {
               $sub->($ctxt,
                       ($upload ?
                            (   $filename,
                                $upload->fh,
                                $upload->size,
                                $upload->type,
                                $upload->info
                            ) :
                            ()
                       )
                   );
            };
            $error = $@;
            $ctxt->{_Failed}++ if $error;
            $error =~ s/(.*) at .*? line \d+\.$/$1/;
        }
    }
    # load
    elsif (my $sub = $package->can($onload || "load_${name}")) {
        $params->{$name} = $sub->($ctxt, $value, $params->{$name});
    }
    else {
        $params->{$name} = $value;
    }

    return {
        file_upload => {
            name => $name,
            value => $params->{$name},
            accept => $accept,
            ($disabled ? (disabled => $disabled) : ()),
            ($onclick ? (onclick => $onclick) : ()),
            ($error ? (error => $error) : ()),
        }
    };
}

sub hidden ($;$$$) {
    my ($name, $value, $index, $onload) = @_;
    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};
    my $params = $ctxt->{Form};
    my $fname = $ctxt->{Name};

    if (!defined($value) && $package->can($onload || "load_${name}")) {
	# load value if not defined
        my $sub = $package->can($onload || "load_${name}");
	$value = $sub->($ctxt, $value, $index);
    }
    if ($params->{"__submitting_$fname"} && ($value ne ($params->get($name.$index))[-1])) {
	die "Someone tried to change your hidden form value!";
    }

    return {
	hidden => {
            name => $name,
            value => $value,
	    index => $index,
        }
    };
}

sub multi_select ($;$$$$$$$) {
    my ($name, $default, $index, $onval, $onload, $disabled, $onclick, $option) = @_;
    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};

    my $params = $ctxt->{Form};
    my $fname = $ctxt->{Name};

    my $error;
    my ($selected, @options);

    # validate
    if ($params->{"__submitting_$fname"}) {
        if (my $sub = $package->can($onval || "validate_${name}")) {
            eval {
                $sub->($ctxt, [$params->get($name.$index)], $index);
            };
            $error = $@;
            $ctxt->{_Failed}++ if $error;
            $error =~ s/(.*) at .*? line \d+\.$/$1/;
        }
    }
    # load
    if (my $sub = $package->can($onload || "load_${name}")) {
        ($selected, @options) = $sub->($ctxt, [$params->get($name.$index)], $default, $index);
    }
    else {
        $selected = [@{$default}];
        @options = map { $$_{name}, $$_{value} } @{$option};
    }

    my %selected = map { $_ => 1 } @$selected;

    my (@keys, @vals);
    while (@options) {
        my ($val, $key) = splice(@options, 0, 2);
        push @keys, $key;
        push @vals, $val;
    }

    return {
        multi_select => {
            name => $name,
            ($error ? ( error => $error ) : ()),
	    index => $index,
            ($disabled ? (disabled => $disabled) : ()),
            ($onclick ? (onclick => $onclick) : ()),
            options => [
                map {
                  {
                    ( ( $selected{$_} ) ? (selected => "selected") : () ),
                    value => $_,
                    text => shift(@vals),
                  }
                } @keys,
            ],
        }
    };
}

sub password ($;$$$$$$$$) {
    my ($name, $default, $width, $maxlength, $index, $onval, $onload,
        $disabled, $onchange) = @_;
    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};

    my $params = $ctxt->{Form};
    my $fname = $ctxt->{Name};

    my $error;

    # validate
    if ($params->{"__submitting_$fname"}) {
        if (my $sub = $package->can($onval || "validate_${name}")) {
            eval {
                $sub->($ctxt, ($params->get($name.$index))[-1], $index);
                $params->{$name.$index} = ($params->get($name.$index))[-1];
            };
            $error = $@;
            $ctxt->{_Failed}++ if $error;
            $error =~ s/(.*) at .*? line \d+\.$/$1/;
        }
    }
    # load
    elsif (my $sub = $package->can($onload || "load_${name}")) {
        $params->{$name.$index} = $sub->($ctxt, $default, ($params->get($name.$index))[-1], $index);
    }
    else {
        $params->{$name.$index} = $default;
    }

    return {
        password => {
            width => $width,
            maxlength => $maxlength,
            name => $name,
            value => ($params->get($name.$index))[-1],
            ($error ? (error => $error) : ()),
	    index => $index,
            ($disabled ? (disabled => $disabled) : ()),
            ($onchange ? (onchange => $onchange) : ()),
            }
        };
}

sub radio {
    die "NOT YET IMPLEMENTED";
}

sub reset ($;$) {
    my ($name, $value) = @_;

    return {
        reset => {
            name => $name,
            ( $value ? (value => $value) : () ),
        }
    };
}

sub single_select ($;$$$$$$$) {
    my ($name, $default, $index, $onval, $onload,
        $disabled, $onchange, $option) = @_;

    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};

    my $params = $ctxt->{Form};
    my $fname = $ctxt->{Name};

    my $error;
    my ($selected, @options);

    # validate
    if ($params->{"__submitting_$fname"}) {
        if (my $sub = $package->can($onval || "validate_${name}")) {
            eval {
                $sub->($ctxt, ($params->get($name.$index))[-1], $index);
                $params->{$name.$index} = ($params->get($name.$index))[-1];
            };
            $error = $@;
            $ctxt->{_Failed}++ if $error;
            $error =~ s/(.*) at .*? line \d+\.$/$1/;
        }
    }
    # load
    if (my $sub = $package->can($onload || "load_${name}")) {
        ($selected, @options) = $sub->($ctxt, ($params->get($name.$index))[-1], $default, $index);
    }
    else {
        $selected = $default;
        @options = map { $$_{name}, $$_{value} } @{$option};
    }

    my (@keys, @vals);
    while (@options) {
        my ($val, $key) = splice(@options, 0, 2);
        push @keys, $key;
        push @vals, $val;
    }

    return {
        single_select => {
            name => $name,
            ($error ? ( error => $error ) : ()),
	    index => $index,
            ($disabled ? (disabled => $disabled) : ()),
            ($onchange ? (onchange => $onchange) : ()),
            options => [
                map {
                  {
                    ( ($selected eq $_) ? (selected => "selected") : () ),
                    value => $_,
                    text => shift(@vals),
                  }
                } @keys,
            ],
        }
    };
}

sub textarea ($;$$$$$$$$$) {
    my ($name, $cols, $rows, $wrap, $default, $index, $onval, $onload,
        $disabled, $onchange) = @_;

    my ($package) = caller;

    no strict 'refs';

    my $ctxt = ${"${package}::_form_ctxt"};

    my $params = $ctxt->{Form};
    my $fname = $ctxt->{Name};

    my $error;

    # validate
    if ($params->{"__submitting_$fname"}) {
        if (my $sub = $package->can($onval || "validate_${name}")) {
            eval {
                $sub->($ctxt, ($params->get($name.$index))[-1], $index);
                $params->{$name.$index} = ($params->get($name.$index))[-1];
            };
            $error = $@;
            $ctxt->{_Failed}++ if $error;
            $error =~ s/(.*) at .*? line \d+\.$/$1/;
        }
    }
    # load
    elsif (my $sub = $package->can($onload || "load_${name}")) {
        $params->{$name.$index} = $sub->($ctxt, $default, ($params->get($name.$index))[-1], $index);
    }
    else {
        $params->{$name.$index} = $default;
    }

    if ($wrap) {
        if ($wrap eq 'no') {
            undef $wrap;
        }
        if ($wrap ne 'yes' && $wrap ne 'y') {
            undef $wrap;
        }
    }

    return {
        textarea => {
            cols => $cols,
            rows => $rows,
            ($wrap ? (wrap => 'wrap') : ()),
            name => $name,
            value => $params->{$name.$index},
            ($error ? (error => $error) : ()),
	    index => $index,
            ($disabled ? (disabled => $disabled) : ()),
            ($onchange ? (onchange => $onchange) : ()),
            }
        };
}

1;
__END__