File Coverage

blib/lib/HTML/SuperForm.pm

Criterion	Covered	Total	%
statement	12	214	5.6
branch	0	68	0.0
condition	0	8	0.0
subroutine	4	24	16.6
pod	11	14	78.5
total	27	328	8.2

package HTML::SuperForm;

use strict;
use HTML::SuperForm::Field;
use Carp;

our $VERSION = 1.06;

my %fields = map { $_ => 1 } qw(textarea text checkbox select radio checkbox_group radio_group password hidden submit);
my %mutators    = map { $_ => 1 } qw(well_formed sticky fallback values_as_labels);
my %accessors    = map { $_ => 1 } qw(field_object params);

sub new {
    my $class = shift;
    my $arg = shift;
    my $field_object = shift || "HTML::SuperForm::Field";

    my $params = {};
    my $method = $ENV{REQUEST_METHOD};
    my $content_type = $ENV{CONTENT_TYPE};
    my $parameters_from = '';

    if(UNIVERSAL::isa($arg, "Apache") && eval("require Apache::Request")) {
        my $apr;
        if(UNIVERSAL::isa($arg, "Apache::Request")) {
            $apr = $arg;
        } else {
            $apr = Apache::Request->instance($arg);
        }
        my @ps = $apr->param();
        for my $p (@ps) {
            my @values = $apr->param($p);

            if(scalar(@values) > 1) {
                $params->{$p} = \@values;
            } else {
                $params->{$p} = $values[0];
            }
        }
        $parameters_from = 'Apache::Request';
    } elsif(UNIVERSAL::isa($arg, "Apache2::RequestRec") && eval("require Apache2::Request")) {
        my $apr;
        if(UNIVERSAL::isa($arg, "Apache2::Request")) {
            $apr = $arg;
        } else {
            $apr = Apache2::Request->new($arg);
        }
        my @ps = $apr->param();
        for my $p (@ps) {
            my @values = $apr->param($p);

            if(scalar(@values) > 1) {
                $params->{$p} = \@values;
            } else {
                $params->{$p} = $values[0];
            }
        }
        $parameters_from = 'Apache2::Request';
    } elsif(ref($arg) eq "HASH") {
        $params = $arg;
        $parameters_from = 'hash reference';
    } elsif(UNIVERSAL::isa($arg, "CGI")) {
        my $vars = $arg->Vars();
        for my $key (keys %$vars) {
            if($vars->{$key} =~ /\0/) {
                $params->{$key} = [ split('\0', $vars->{$key}) ];
            } else {
                $params->{$key} = $vars->{$key};
            }
        }
        $parameters_from = 'CGI';
    } elsif($ENV{CONTENT_TYPE} eq 'application/x-www-form-urlencoded') {
        my $query = $ENV{QUERY_STRING};

        my @pairs = split(/[&;]/, $query);

        if($method eq 'POST') {
            my $len = $ENV{CONTENT_LENGTH};
            my $pquery;
            sysread STDIN, $pquery, $len;

            push(@pairs, split(/[&;]/, $pquery));
        }

        for my $pair (@pairs) {
            my ($key, $value) = split('=', $pair);
            $key =~ tr/+/ /;
            $key =~ s/%([0-9A-Za-z]{2})/chr(hex($1))/ge;
            $value =~ tr/+/ /;
            $value =~ s/%([0-9A-Za-z]{2})/chr(hex($1))/ge;
            if(exists($params->{$key})) {
                if(ref($params->{$key}) eq "ARRAY") {
                    push(@{$params->{$key}}, $value);
                } else {
                    $params->{$key} = [ $params->{$key}, $value ];
                }
            } else {
                $params->{$key} = $value;
            }
        }
        $parameters_from = 'ENV';
    }

    my $self = {
        _params => $params,
        _method => $method,
        _sticky => 0,
        _fallback => 0,
        _well_formed => 1,
        _values_as_labels => 1,
        _field_object => $field_object,
        _attributes => {
            method => "POST"
        },
        _other_info => {},
        _parameters_from => $parameters_from
    };

    bless $self, $class;

    return $self;
}

sub name {
    my $self = shift;
    return $self->{_attributes}{name};
}

sub set {
    my $self = shift;

    my %hash;

    if(ref($_[0]) eq "HASH") {
        %hash = %{ shift() };
    } else {
        %hash = @_;
    }

    $self->{_other_info} = {
        %{$self->{_other_info}},
        %hash,
    };

    return;
}

sub get {
    my $self = shift;

    my @return;

    for my $key (@_) {
        if(exists($self->{_other_info}{$key})) {
            push(@return, $self->{_other_info}{$key});
        } else {
            carp "WARNING: nothing stored under key $key";
        }
    }

    return wantarray         ? @return    :
        scalar(@return) == 1 ? $return[0] : \@return;
}

sub start_form {
    my $self = shift;

    my $config = {};

    if(ref($_[0]) eq "HASH") {
        $config = shift;
    } else {
        %$config = @_;
    }

    $self->{_attributes} = {
        %{$self->{_attributes}},
        %$config,
    };

    my $tag = "

    my $attrib_str = join(' ', map { qq|$_="$self->{_attributes}{$_}"| }
            keys %{$self->{_attributes}});

    $tag .= " $attrib_str" if $attrib_str;
    $tag .= ">";

    if(lc($self->{_attributes}{method}) eq lc($self->{_method})) {
        $self->set_sticky(1);
    }

    return $tag;
}

sub end_form {
    my $self = shift;

    return "";
}

sub set_sticky {
    my $self = shift;
    $self->sticky(shift);
}

sub no_of_fields {
    my $self = shift;
    my $name = shift;

    if(exists($self->{_defaults}{$name})) {
        if(ref($self->{_defaults}{$name}) eq "ARRAY") {
            return scalar(@{$self->{_defaults}{$name}});
        } else {
            return 1;
        }
    }
    return 0;
}

sub trim_params {
    my $self = shift;

    for my $key (keys %{$self->{_params}}) {
        $self->{_params}{$key} =~ s/^\s+//;
        $self->{_params}{$key} =~ s/\s+$//;
    }
}

sub param {
    my $self = shift;

    if(ref($_[0]) eq "HASH") {
        for my $key (keys %{$_[0]}) {
            $self->{_params}{$key} = $_[0]->{$key};
        }
        return;
    } elsif(scalar(@_) > 1) {
        my %hash = @_;
        for my $key (keys %hash) {
            $self->{_params}{$key} = $hash{$key};
        }
        return;
    }

    return $self->{_params}{$_[0]};
}

sub add_default {
    my $self = shift;

    my %hash;

    if(ref($_[0]) eq "HASH") {
        %hash = %{$_[0]};
    } else {
        %hash = @_;
    }

    while(my ($key, $value) = each %hash) {
        if(exists($self->{_defaults}{$key})) {
            if(ref($self->{_defaults}{$key}) eq "ARRAY") {
                push(@{$self->{_defaults}{$key}}, $value);
            } else {
                $self->{_defaults}{$key} = [ $self->{_defaults}{$key}, $value ];
            }
        } else {
            $self->{_defaults}{$key} = $value;
        }
    }

    return;
}

sub defaults {
    my $self = shift;

    my $defaults = {};

    for my $key (keys %{$self->{_defaults}}) {
        if(ref($self->{_defaults}) eq "ARRAY") {
            $defaults->{$key} = [ @{$self->{_defaults}{$key}} ];
        } else {
            $defaults->{$key} = $self->{_defaults}{$key};
        }
    }

    return $defaults;
}

sub set_default {
    my $self = shift;

    my %hash;

    if(ref($_[0]) eq "HASH") {
        %hash = %{$_[0]};
    } else {
        %hash = @_;
    }

    while( my ($key, $value) = each %hash) {
        $self->{_defaults}{$key} = $value;
    }

    return;
}

sub exists_param {
    my $self = shift;
    my $key = shift;

    return exists($self->{_params}{$key});
}

sub AUTOLOAD {
    my $self = $_[0];

    my ($key) = ${*AUTOLOAD} =~ /::([^:]*)$/;

    {
        no strict "refs";
        if(exists($fields{$key})) {
            my $field_name = ucfirst($key);
            $field_name =~ s/_(\w)/\U$1/g;

            my $object = $self->{_field_object} . "::" . $field_name;

            eval "require $object";
            *{"HTML::SuperForm::$key"} = sub {
                return $object->new(@_);
            };
            goto &{"HTML::SuperForm::$key"};
        }

        if(exists($mutators{$key})) {
            *{"HTML::SuperForm::$key"} = sub {
                my $self = shift;
                my $val = shift;

                if(defined($val)) {
                    $self->{'_' . $key} = $val;
                    return;
                }
                return $self->{'_' . $key};
            };
            goto &{"HTML::SuperForm::$key"};
        }

        if(exists($accessors{$key})) {
            *{"HTML::SuperForm::$key"} = sub {
                my $self = shift;
                return $self->{'_' . $key};
            };
            goto &{"HTML::SuperForm::$key"};
        }

        if(exists($self->{attributes}{$key})) {
            *{"HTML::SuperForm::$key"} = sub {
                my $self = shift;
                return $self->{_attributes}{$key};
            };
            goto &{"HTML::SuperForm::$key"};
        } else {
            croak "ERROR: attribute $key doesn't exist";
        }
    }

    return;
}

sub DESTROY {}

1;
__END__