# # $Id: Form.pm,v 0.1 2001/03/31 10:54:01 ram Exp $ # # Copyright (c) 2001, Raphael Manfredi # # You may redistribute only under the terms of the Artistic License, # as specified in the README file that comes with the distribution. # # HISTORY # $Log: Form.pm,v $ # Revision 0.1 2001/03/31 10:54:01 ram # Baseline for first Alpha release. # # $EndLog$ # use strict; package CGI::Test::Form; # # Class interfacing with the content of a
tag, which comes from # a CGI::Test::Page object. The tree nodes we are playing with here are # direct pointers into the node of the page object. # use Carp::Datum; use Log::Agent; # # ->make # # Creation routine # sub make { DFEATURE my $f_; my $self = bless {}, shift; my ($node, $page) = @_; DREQUIRE $node->isa("HTML::Element"); DREQUIRE $page->isa("CGI::Test::Page"); DREQUIRE $node->tag eq "form"; $self->{tree} = $node; # is the root node of the tree $self->{page} = $page; $self->{enctype} = $node->attr("enctype") || "application/x-www-form-urlencoded"; $self->{method} = uc $node->attr("method") || "POST"; foreach my $attr (qw(action name accept accept-charset)) { my $oattr = $attr; $oattr =~ s/-/_/g; my $value = $node->attr($attr); $self->{$oattr} = $value if defined $value; } # # Although ACTION is now required in newer HTML DTDs, it was optional # in HTML 2.0 and defaults to the base URI of the document. # $self->{action} = $page->uri->as_string unless exists $self->{action}; return DVAL $self; } # # Attribute access # sub tree { $_[0]->{tree} } sub page { $_[0]->{page} } sub enctype { $_[0]->{enctype} } sub action { $_[0]->{action} } sub method { $_[0]->{method} } sub name { $_[0]->{name} } sub accept { $_[0]->{accept} } sub accept_charset { $_[0]->{accept_charset} } # # Lazy attribute access # sub buttons { $_[0]->{buttons} || $_[0]->_xtract("buttons") } sub inputs { $_[0]->{inputs} || $_[0]->_xtract("inputs") } sub menus { $_[0]->{menus} || $_[0]->_xtract("menus") } sub radios { $_[0]->{radios} || $_[0]->_xtract("radios") } sub checkboxes { $_[0]->{checkboxes} || $_[0]->_xtract("checkboxes") } sub hidden { $_[0]->{hidden} || $_[0]->_xtract("hidden") } sub widgets { $_[0]->{widgets} || $_[0]->_xtract("widgets") } # # Second-order lazy attributes # sub submits { $_[0]->{submits} || ($_[0]->{submits} = $_[0]->_submits) } sub radio_groups { $_[0]->radios && $_[0]->{radio_groups} } sub checkbox_groups { $_[0]->checkboxes && $_[0]->{checkbox_groups} } # # Expanded lists -- syntactic sugar # sub button_list { @{$_[0]->buttons} } sub input_list { @{$_[0]->inputs} } sub menu_list { @{$_[0]->menus} } sub radio_list { @{$_[0]->radios} } sub checkbox_list { @{$_[0]->checkboxes} } sub hidden_list { @{$_[0]->hidden} } sub widget_list { @{$_[0]->widgets} } sub submit_list { @{$_[0]->submits} } # # By parameter-name n-n widget access (one widget returned for each asked) # sub button_by_name { my $s = shift; $s->_by_name($s->buttons, @_) } sub input_by_name { my $s = shift; $s->_by_name($s->inputs, @_) } sub menu_by_name { my $s = shift; $s->_by_name($s->menus, @_) } sub radio_by_name { my $s = shift; $s->_by_name($s->radios, @_) } sub checkbox_by_name { my $s = shift; $s->_by_name($s->checkboxes, @_) } sub hidden_by_name { my $s = shift; $s->_by_name($s->hidden, @_) } sub widget_by_name { my $s = shift; $s->_by_name($s->widgets, @_) } sub submit_by_name { my $s = shift; $s->_by_name($s->submits, @_) } # # By parameter-name 1-n widget access (many widgets may be returned, one asked) # sub buttons_named { my $s = shift; $s->_all_named($s->buttons, @_) } sub inputs_named { my $s = shift; $s->_all_named($s->inputs, @_) } sub menus_named { my $s = shift; $s->_all_named($s->menus, @_) } sub radios_named { my $s = shift; $s->_all_named($s->radios, @_) } sub checkboxes_named { my $s = shift; $s->_all_named($s->checkboxes, @_) } sub hidden_named { my $s = shift; $s->_all_named($s->hidden, @_) } sub widgets_named { my $s = shift; $s->_all_named($s->widgets, @_) } sub submits_named { my $s = shift; $s->_all_named($s->submits, @_) } # # Convenience routines around ->_matching(). # sub buttons_matching { my $s = shift; $s->_matching($s->buttons, @_) } sub inputs_matching { my $s = shift; $s->_matching($s->inputs, @_) } sub menus_matching { my $s = shift; $s->_matching($s->menus, @_) } sub radios_matching { my $s = shift; $s->_matching($s->radios, @_) } sub checkboxes_matching { my $s = shift; $s->_matching($s->checkboxes, @_) } sub hidden_matching { my $s = shift; $s->_matching($s->hidden, @_) } sub widgets_matching { my $s = shift; $s->_matching($s->widgets, @_) } sub submits_matching { my $s = shift; $s->_matching($s->submits, @_) } # # ->reset # # Reset form state, restoring all the widget controls to the value they # had upon entry. # sub reset { DFEATURE my $f_; my $self = shift; foreach my $w ($self->widget_list) { $w->reset_state; } return DVOID; } # # ->submit # # Submit this form. # Returns resulting CGI::Test::Page. # sub submit { DFEATURE my $f_; my $self = shift; my $method = $self->method; my $input = $self->_output; # Input to the request we're about to make my $action = $self->_action_url; my $page = $self->page; my $server = $page->server; my $result; if ($method eq "GET") { logconfess "GET requests only allowed URL encoding, not %s", $input->mime_type unless $input->mime_type eq "application/x-www-form-urlencoded"; $action->query($input->data); $result = $server->GET($action->as_string, $page->user); } elsif ($method eq "POST") { $result = $server->POST($action->as_string, $input, $page->user); } else { logconfess "unsupported method $method for FORM action"; } return DVAL $result; } # # ->_xtract # # Widget extraction routine: traverse the tree and create an instance # of CGI::Test::Form::Widget per encountered widget. The dynamic type depends # on the widget type, e.g. a button creates a CGI::Test::Form::Widget::Button # object. # # Widgets are also sorted by type, and stored as object attribute: # # buttons all buttons # inputs text area, text fields, password fields # menus popup menus # radios radio buttons # checkboxes all checkboxes # hidden all hidden fields # widgets all widgets, whatever their type. # # The special attribute `radio_groups' is only built when there is at least # one radio button. # # Although we extract ALL the widgets, caller is only interested in a # specific list, given in $which. Therefore, returns a list ref on that # particular set. # sub _xtract { DFEATURE my $f_; my $self = shift; my ($which) = @_; # # We may not create an instance of all those classes, but the cost of # lazily requiring them would probably outweigh the cost of loading # them once and for all, on reasonably sized forms. # require CGI::Test::Form::Widget::Button::Submit; require CGI::Test::Form::Widget::Button::Reset; require CGI::Test::Form::Widget::Button::Image; require CGI::Test::Form::Widget::Button::Plain; require CGI::Test::Form::Widget::Input::Text_Field; require CGI::Test::Form::Widget::Input::Text_Area; require CGI::Test::Form::Widget::Input::Password; require CGI::Test::Form::Widget::Input::File; require CGI::Test::Form::Widget::Menu::List; require CGI::Test::Form::Widget::Menu::Popup; require CGI::Test::Form::Widget::Box::Radio; require CGI::Test::Form::Widget::Box::Check; require CGI::Test::Form::Widget::Hidden; # # Initiate traversal to locate all widgets nodes. # my %is_widget = map { $_ => 1 } qw(input textarea select button isindex); my @wg = $self->tree->look_down( sub { $is_widget{$_[0]->tag} } ); # # Initialize all lists to be empty # foreach my $attr ( qw(buttons inputs radios checkboxes hidden menus widgets) ) { $self->{$attr} = []; } # # And now sort them out. # my %input = ( # [ class name, attribute ] "submit" => ['Button::Submit', "buttons"], "reset" => ['Button::Reset', "buttons"], "image" => ['Button::Image', "buttons"], "text" => ['Input::Text_Field', "inputs"], "file" => ['Input::File', "inputs"], "password" => ['Input::Password', "inputs"], "radio" => ['Box::Radio', "radios"], "checkbox" => ['Box::Check', "checkboxes"], "hidden" => ['Hidden', "hidden"], ); my %button = ( # [ class name, attribute ] "submit" => ['Button::Submit', "buttons"], "reset" => ['Button::Reset', "buttons"], "button" => ['Button::Plain', "buttons"], ); my $wlist = $self->{widgets}; # All widgets also inserted there foreach my $node (@wg) { my $tag = $node->tag; my ($class, $attr); my $hlookup; if ($tag eq "input") { $hlookup = \%input; } elsif ($tag eq "textarea") { ($class, $attr) = ("Input::Text_Area", "inputs"); } elsif ($tag eq "select") { $attr = "menus"; $class = ($node->attr("multiple") || defined $node->attr("size")) ? "Menu::List" : "Menu::Popup"; } elsif ($tag eq "button") { $hlookup = \%button; } elsif ($tag eq "isindex") { logwarn "ISINDEX is deprecated, ignoring %s", $node->starttag; next; } else { logconfess "reached tag '$tag': invalid tree look_down()?" } # # If $hlookup is defined, we need to look at the TYPE attribute # within the tag to determine the object to build. # # This handles and