package CGI::Test::Form; use strict; #################################################################### # $Id: Form.pm,v 1.2 2003/09/29 11:00:34 mshiltonj Exp $ # $Name: cgi-test_0-104_t1 $ #################################################################### # 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. # # # 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; # # 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. # use CGI::Test::Form::Widget::Button::Submit; use CGI::Test::Form::Widget::Button::Reset; use CGI::Test::Form::Widget::Button::Image; use CGI::Test::Form::Widget::Button::Plain; use CGI::Test::Form::Widget::Input::Text_Field; use CGI::Test::Form::Widget::Input::Text_Area; use CGI::Test::Form::Widget::Input::Password; use CGI::Test::Form::Widget::Input::File; use CGI::Test::Form::Widget::Menu::List; use CGI::Test::Form::Widget::Menu::Popup; use CGI::Test::Form::Widget::Box::Radio; use CGI::Test::Form::Widget::Box::Check; use CGI::Test::Form::Widget::Hidden; ###################################################################### # # ->new # # Creation routine # ###################################################################### sub new { DFEATURE my $f_; my $this = bless {}, shift; my ($node, $page) = @_; DREQUIRE $node->isa("HTML::Element"); DREQUIRE $page->isa("CGI::Test::Page"); DREQUIRE $node->tag eq "form"; $this->{tree} = $node; # is the root node of the tree $this->{page} = $page; $this->{enctype} = $node->attr("enctype") || "application/x-www-form-urlencoded"; $this->{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); $this->{$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. # $this->{action} = $page->uri->as_string unless exists $this->{action}; return DVAL $this; } ###################################################################### # DEPRECATED ###################################################################### sub make { # my $class = shift; return $class->new(@_); } # # Attribute access # ###################################################################### sub tree { my $this = shift; return $this->{tree}; } ###################################################################### sub page { my $this = shift; return $this->{page}; } ###################################################################### sub enctype { my $this = shift; return $this->{enctype}; } ###################################################################### sub action { my $this = shift; return $this->{action}; } ###################################################################### sub method { my $this = shift; return $this->{method}; } ###################################################################### sub name { my $this = shift; return $this->{name}; } ###################################################################### sub accept { my $this = shift; return $this->{accept}; } ###################################################################### sub accept_charset { my $this = shift; return $this->{accept_charset}; } # # Lazy attribute access # ###################################################################### sub buttons { my $this = shift; return $this->{buttons} || $this->_xtract("buttons"); } ###################################################################### sub inputs { my $this = shift; return $this->{inputs} || $this->_xtract("inputs"); } ###################################################################### sub menus { my $this = shift; return $this->{menus} || $this->_xtract("menus"); } ###################################################################### sub radios { my $this = shift; return $this->{radios} || $this->_xtract("radios"); } ###################################################################### sub checkboxes { my $this = shift; return $this->{checkboxes} || $this->_xtract("checkboxes"); } ###################################################################### sub hidden { my $this = shift; return $this->{hidden} || $this->_xtract("hidden"); } ###################################################################### sub widgets { my $this = shift; return $this->{widgets} || $this->_xtract("widgets"); } # # Second-order lazy attributes # ###################################################################### sub submits { my $this = shift; return $this->{submits} || ($this->{submits} = $this->_submits); } ###################################################################### sub radio_groups { my $this = shift; return $this->radios() && $this->{radio_groups}; } ###################################################################### sub checkbox_groups { my $this = shift; return $this->checkboxes() && $this->{checkbox_groups}; } # # Expanded lists -- syntactic sugar # ###################################################################### sub button_list { my $this = shift; return @{$this->buttons()}; } ###################################################################### sub input_list { my $this = shift; return @{$this->inputs()}; } ###################################################################### sub menu_list { my $this = shift; return @{$this->menus()}; } ###################################################################### sub radio_list { my $this = shift; return @{$this->radios()}; } ###################################################################### sub checkbox_list { my $this = shift; return @{$this->checkboxes()}; } ###################################################################### sub hidden_list { my $this = shift; return @{$this->hidden()}; } ###################################################################### sub widget_list { my $this = shift; return @{$this->widgets()}; } ###################################################################### sub submit_list { my $this = shift; @{$this->submits()}; } # # By parameter-name n-n widget access (one widget returned for each asked) # ###################################################################### sub button_by_name { my $this = shift; $this->_by_name($this->buttons, @_); } ###################################################################### sub input_by_name { my $this = shift; $this->_by_name($this->inputs, @_); } ###################################################################### sub menu_by_name { my $this = shift; $this->_by_name($this->menus, @_); } ###################################################################### sub radio_by_name { my $this = shift; $this->_by_name($this->radios, @_); } ###################################################################### sub checkbox_by_name { my $this = shift; $this->_by_name($this->checkboxes, @_); } ###################################################################### sub hidden_by_name { my $this = shift; $this->_by_name($this->hidden, @_); } ###################################################################### sub widget_by_name { my $this = shift; $this->_by_name($this->widgets, @_); } ###################################################################### sub submit_by_name { my $this = shift; return $this->_by_name($this->submits, @_); } # # By parameter-name 1-n widget access (many widgets may be returned, one asked) # ###################################################################### sub buttons_named { my $this = shift; return $this->_all_named($this->buttons, @_); } ###################################################################### sub inputs_named { my $this = shift; return $this->_all_named($this->inputs, @_); } ###################################################################### sub menus_named { my $this = shift; return $this->_all_named($this->menus, @_); } ###################################################################### sub radios_named { my $this = shift; return $this->_all_named($this->radios, @_); } ###################################################################### sub checkboxes_named { my $this = shift; return $this->_all_named($this->checkboxes, @_); } ###################################################################### sub hidden_named { my $this = shift; return $this->_all_named($this->hidden, @_); } ###################################################################### sub widgets_named { my $this = shift; return $this->_all_named($this->widgets, @_); } ###################################################################### sub submits_named { my $this = shift; return $this->_all_named($this->submits, @_); } # # Convenience routines around ->_matching(). # ###################################################################### sub buttons_matching { my $this = shift; return $this->_matching($this->buttons, @_); } ###################################################################### sub inputs_matching { my $this = shift; return $this->_matching($this->inputs, @_); } ###################################################################### sub menus_matching { my $this = shift; return $this->_matching($this->menus, @_); } ###################################################################### sub radios_matching { my $this = shift; return $this->_matching($this->radios, @_); } ###################################################################### sub checkboxes_matching { my $this = shift; return $this->_matching($this->checkboxes, @_); } ###################################################################### sub hidden_matching { my $this = shift; return $this->_matching($this->hidden, @_); } ###################################################################### sub widgets_matching { my $this = shift; return $this->_matching($this->widgets, @_); } ###################################################################### sub submits_matching { my $this = shift; return $this->_matching($this->submits, @_); } ###################################################################### # # ->reset # # Reset form state, restoring all the widget controls to the value they # had upon entry. # ###################################################################### sub reset { DFEATURE my $f_; my $this = shift; foreach my $w ($this->widget_list) { $w->reset_state; } return DVOID; } ###################################################################### # # ->submit # # Submit this form. # Returns resulting CGI::Test::Page. # ###################################################################### sub submit { DFEATURE my $f_; my $this = shift; my $method = $this->method; my $input = $this->_output; # Input to the request we're about to make my $action = $this->_action_url; my $page = $this->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 $this = shift; my ($which) = @_; # # Initiate traversal to locate all widgets nodes. # my %is_widget = map {$_ => 1} qw(input textarea select button isindex); my @wg = $this->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) { $this->{$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 = $this->{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