package Rose::HTML::Form; use strict; use Carp; use Clone::PP; use Rose::URI; use Scalar::Util(); use URI::Escape qw(uri_escape); use Rose::HTML::Util(); use Rose::HTML::Object::Errors qw(:form); our @ISA = qw(Rose::HTML::Object::WithWrapAroundChildren Rose::HTML::Form::Field Rose::HTML::Form::Field::Collection); our $VERSION = '0.616'; # Avoid problems caused by circular dependencies by loading these # modules at runtime. XXX: This whole hierarchy needs an overhaul. require Rose::HTML::Form::Field; require Rose::HTML::Form::Field::Collection; require Rose::HTML::Object::WithWrapAroundChildren; # Multiple inheritence never quite works out the way I want it to... Rose::HTML::Form::Field::Collection->import_methods ( 'xhtml', 'html', 'prepare', 'hidden_field', 'hidden_fields', 'html_hidden_field', 'xhtml_hidden_field', 'html_hidden_fields', 'xhtml_hidden_fields', ); __PACKAGE__->add_valid_html_attrs ( 'action', # %URI; #REQUIRED -- server-side form handler -- 'method', # (GET|POST) GET -- HTTP method used to submit the form-- 'enctype', # %ContentType; "application/x-www-form-urlencoded" 'accept', # %ContentTypes; #IMPLIED -- list of MIME types for file upload -- 'name', # CDATA #IMPLIED -- name of form for scripting -- 'onsubmit', # %Script; #IMPLIED -- the form was submitted -- 'onreset', # %Script; #IMPLIED -- the form was reset -- 'accept-charset', # %Charsets; #IMPLIED -- list of supported charsets -- 'target', # http://www.w3.org/TR/xhtml-modularization/abstract_modules.html#s_targetmodule 'novalidate', ); __PACKAGE__->add_required_html_attrs( { action => '', method => 'get', enctype => 'application/x-www-form-urlencoded', }); use constant UNSAFE_URI_CHARS => '^\w\d?\057=.:-'; use Rose::HTML::Form::Constants qw(FF_SEPARATOR); # Variable for use in regexes our $FF_SEPARATOR_RE = quotemeta FF_SEPARATOR; our $Debug = 0; use Rose::Object::MakeMethods::Generic ( scalar => [ 'uri_base', 'rank', ], 'scalar --get_set_init' => [ 'uri_separator', 'form_rank_counter', 'recursive_init_fields', ], boolean => [ 'coalesce_query_string_params' => { default => 1 }, 'build_on_init' => { default => 1 }, ], ); # # Class data # use Rose::Class::MakeMethods::Generic ( inheritable_scalar => [ '_delegate_to_subforms', ], inheritable_boolean => [ 'default_recursive_init_fields', 'default_trim_xy_params', ], ); __PACKAGE__->delegate_to_subforms('compile'); __PACKAGE__->default_recursive_init_fields(0); __PACKAGE__->default_trim_xy_params(1); # # Class methods # sub new { my($class) = shift; my $self = { params => {}, fields => {}, validate_field_html_attrs => 1, }; bless $self, $class; $self->init(@_); return $self; } sub init_recursive_init_fields { shift->default_recursive_init_fields } sub trim_xy_params { my($self) = shift; if(@_) { my $val = $self->{'trim_xy_params'} = $_[0] ? 1 : 0; foreach my $form ($self->forms) { $form->trim_xy_params($val); } return $val; } return defined $self->{'trim_xy_params'} ? $self->{'trim_xy_params'} : ref($self)->default_trim_xy_params; } sub delegate_to_subforms { my($class) = shift; $class = ref $class if(ref $class); if(@_) { my $value = shift; # Dumb regex to avoid non-numeric comparison warning $value = 'runtime' if($value =~ /\d/ && $value == 1); unless(!$value || $value eq 'compile' || $value eq 'runtime') { croak "Invalid delegate_to_subforms() value: '$value'"; } return $class->_delegate_to_subforms($value); } return $class->_delegate_to_subforms; } # # Object methods # sub init_uri_separator { '&' } sub init { my($self) = shift; $self->SUPER::init(@_); $self->build_form() if($self->build_on_init); } sub html_element { 'form' } sub xhtml_element { 'form' } sub action { shift->html_attr('action', @_) } sub method { shift->html_attr('method', @_) } sub build_form { } sub name { my($self) = shift; if(@_) { return $self->html_attr('name', shift); } else { unless(defined $self->html_attr('name')) { return $self->form_name; } return $self->html_attr('name'); } } sub validate_field_html_attrs { my($self) = shift; if(@_) { foreach my $field ($self->fields) { $field->validate_html_attrs(@_); } return $self->{'validate_field_html_attrs'} = $_[0] ? 1 : 0; } return $self->{'validate_field_html_attrs'}; } # Override inherited, non-public methods with fast-returning # "don't care" versions. sub _is_full { 0 } sub _set_input_value { } sub is_full { 0 } sub is_repeatable { $_[0]->is_repeatable_form || $_[0]->is_repeatable_field ? 1 : 0 } sub is_repeatable_field { 0 } sub is_repeatable_form { 0 } sub is_empty { my($self) = shift; foreach my $field ($self->fields) { return 0 unless($field->is_empty); } foreach my $form ($self->forms) { return 0 unless($form->is_empty); } return 1; } sub empty_is_ok { my($self) = shift; if(@_) { foreach my $form ($self->forms) { $form->empty_is_ok(@_); } return $self->SUPER::empty_is_ok(@_); } my $ok = $self->SUPER::empty_is_ok(@_); return $ok unless($ok); foreach my $form ($self->forms) { return 0 unless($form->empty_is_ok); } return $ok; } # Empty contents instead of replacing ref sub delete_params { %{shift->{'params'}} = () } sub params_from_cgi { my($self, $cgi) = @_; croak "Missing CGI argument to params_from_cgi" unless(@_ > 1); unless(UNIVERSAL::isa($cgi, 'CGI') || UNIVERSAL::can($cgi, 'param')) { croak "Argument to params_from_cgi() is not a CGI object and ", "does not have a param() method"; } my %params; foreach my $param ($cgi->param) { my @values = $cgi->param($param); $params{$param} = @values > 1 ? \@values : $values[0]; } $self->params(\%params); } # IIn a reasonably modern perl, the optimizer will eliminate the # blocks of code that are conditional upon these constants when the # value is zero. use constant MP2 => exists $ENV{'MOD_PERL_API_VERSION'} && $ENV{'MOD_PERL_API_VERSION'} > 1 ? 1 : 0; use constant MP1 => # Special environment variable for the test suite ($ENV{'MOD_PERL'} || $ENV{'RHTMLO_TEST_MOD_PERL'}) && (!exists $ENV{'MOD_PERL_API_VERSION'} || $ENV{'MOD_PERL_API_VERSION'} == 1) ? 1 : 0; use constant MP0 => $ENV{'MOD_PERL'} ? 0 : 1; my $Loaded_APR1 = 0; my $Loaded_APR2 = 0; sub params_from_apache { my($self, $apr) = @_; croak "Missing apache request argument to params_from_apache" unless(@_ > 1); if(MP0) { unless(UNIVERSAL::can($apr, 'param')) { croak "Argument to params_from_apache() does not have a param() method"; } } elsif(MP1) { if(UNIVERSAL::isa($apr, 'Apache')) { unless($Loaded_APR1) # cheaper than require (really!) { require Apache::Request; $Loaded_APR1 = 1; } $apr = Apache::Request->instance($apr); } elsif(!UNIVERSAL::isa($apr, 'Apache::Request') && !UNIVERSAL::can($apr, 'param')) { croak "Argument to params_from_apache() is not an Apache or ", "Apache::Request object and does not have a param() method"; } } elsif(MP2) { if(UNIVERSAL::isa($apr, 'Apache2::RequestRec')) { unless($Loaded_APR2) # cheaper than require (really!) { require Apache2::Request; $Loaded_APR2 = 1; } $apr = Apache2::Request->new($apr); } elsif(!UNIVERSAL::isa($apr, 'Apache2::Request') && !UNIVERSAL::can($apr, 'param')) { croak "Argument to params_from_apache() is not an Apache2::RequestRec ", "or Apache2::Request object and does not have a param() method"; } } my %params; foreach my $param ($apr->param) { my @values = $apr->param($param); $params{$param} = @values > 1 ? \@values : $values[0]; } $self->params(\%params); } sub params { my($self) = shift; if(@_) { if(@_ == 1 && ref $_[0] eq 'HASH') { $self->{'params'} = $_[0]; } elsif(@_ % 2 == 0) { $self->{'params'} = Clone::PP::clone({ @_ }); } else { croak(ref($self), '::params() - got odd number of arguments: '); } if($self->trim_xy_params) { foreach my $param (keys %{$self->{'params'}}) { if($param =~ /^(.+)\.[xy]$/) { delete $self->{'params'}{$param}; $self->{'params'}{$1} = 1; } } } foreach my $form ($self->forms) { $form->params($self->{'params'}); } } my $want = wantarray; return unless(defined $want); return ($want) ? %{ Clone::PP::clone($self->{'params'}) } : $self->{'params'}; } sub param_exists { my($self, $param) = @_; no warnings; return exists $self->{'params'}{$param}; } sub params_exist { (keys %{$_[0]->{'params'}}) ? 1 : 0 } sub param_exists_for_field { my($self, $name) = @_; $name = $name->name if(UNIVERSAL::isa($name, 'Rose::HTML::Form::Field')); return 0 unless($self->field($name)); my $nibble = $name; my $found_form = 0; while(length $nibble) { if($self->form($nibble) && !$self->field($nibble)) { $found_form = 1; last; } return 1 if($self->param_exists($nibble)); $nibble =~ s/\.[^.]+$// || last; } foreach my $field ($found_form ? $self->form($nibble)->fields : $self->field($name)) { if($field->can('subfield_names')) { foreach my $subname ($field->subfield_names) { # Skip unrelated subfields next unless(index($name, $subname) == 0 || index($subname, $name) == 0); return 1 if($self->param_exists($subname)); } } } return 0; } sub param_value_exists { my($self, $param, $value) = @_; croak(ref($self), '::param_value_exists() requires a param name plus a value') unless(@_ == 3); $param = $self->param($param); return 0 unless($param); foreach my $existing_value ((ref $param) ? @$param : $param) { return 1 if($existing_value eq $value); } return 0; } sub param { my($self, $param, $value) = @_; if(@_ == 2) { if(exists $self->{'params'}{$param}) { if(wantarray) { if(ref $self->{'params'}{$param}) { return @{$self->{'params'}{$param}}; } return ($self->{'params'}{$param}); } return $self->{'params'}{$param}; } return; } elsif(@_ == 3) { return $self->{'params'}{$param} = $value; } croak(ref($self), '::param() requires a param name plus an optional value'); } sub delete_param { my($self, $param, @values) = @_; croak(ref($self), '::delete_param() requires a param name') unless(@_ >= 2); @values = @{$values[0]} if(@values == 1 && ref $values[0] eq 'ARRAY'); if(@values) { my %values = map { $_ => 1 } @values; my $current = $self->{'params'}{$param}; if(ref $current) { my @new; foreach my $val (@$current) { push(@new, $val) unless(exists $values{$val}); } if(@new) { $self->{'params'}{$param} = @new > 1 ? \@new : $new[0]; } else { delete $self->{'params'}{$param}; } } elsif(exists $values{$self->{'params'}{$param}}) { delete $self->{'params'}{$param}; } } else { delete $self->{'params'}{$param}; } } sub add_param_value { my($self, $param, $value) = @_; croak(ref($self), '::add_param() requires a param name plus a value') unless(@_ == 3); my $current = $self->{'params'}{$param}; if(ref $current) { push(@$current, ((ref $value) ? @$value : $value)); } elsif(defined $current) { $current = [ $current, ((ref $value) ? @$value : $value) ]; } else { $current = [ ((ref $value) ? @$value : $value) ]; } $self->{'params'}{$param} = $current; } sub self_uri { my($self) = shift; my $uri_root = $self->uri_base . $self->html_attr('action'); my $self_uri = $uri_root; if(keys %{$self->{'params'}}) { $self_uri .= '?' unless($self_uri =~ /\?$/); $self_uri .= $self->query_string; } return Rose::URI->new($self_uri); } # XXX: To document or not to document, that is the question... sub query_hash { Rose::URI->new(query => shift->query_string)->query_hash } sub query_string { my($self) = shift; my $coalesce = $self->coalesce_query_string_params; my %params; my @fields = $self->fields; while(my $field = shift(@fields)) { unless($coalesce) { if($field->isa('Rose::HTML::Form::Field::Compound')) { unshift(@fields, $field->fields); next; } } my $value = $field->output_value; next unless(defined $value); push(@{$params{$field->name}}, ref $value ? @$value : $value); } my $qs = ''; my $sep = $self->uri_separator; no warnings; foreach my $param (sort keys(%params)) { my $values = $params{$param}; $qs .= $sep if($qs); $qs .= join($sep, map { $param . '=' . uri_escape($_, UNSAFE_URI_CHARS) } @$values); } return $qs; } sub validate { my($self, %args) = @_; $args{'cascade'} = 1 unless(exists $args{'cascade'}); my $fail = 0; my $cascade = $args{'cascade'}; if($cascade) { foreach my $form ($self->forms) { next if($form->is_empty && $form->empty_is_ok); $Debug && warn "Validating sub-form ", $form->form_name, "\n"; unless($form->validate(%args)) { $self->add_error($form->error) if($form->error); $fail++; } } } unless($args{'form_only'}) { return 1 if($self->is_empty && $self->empty_is_ok); foreach my $field ($self->fields) { if($field->parent_form ne $self) { $Debug && warn "Skipping validation of field ", $field->name, " in child form\n"; } else { $Debug && warn "Validating ", $field->name, "\n"; $fail++ unless($field->validate); } } } if($fail) { unless($self->has_errors) { $self->add_error_id(FORM_HAS_ERRORS); } return 0; } return 1; } sub init_fields_with_cgi { my($self) = shift; $self->params_from_cgi(shift); $self->init_fields(@_); } sub init_fields_with_apache { my($self) = shift; $self->params_from_apache(shift); $self->init_fields(@_); } sub init_fields { my($self, %args) = @_; $self->clear() unless($args{'no_clear'}); if(exists $args{'recursive'} ? $args{'recursive'} : $self->recursive_init_fields) { foreach my $field ($self->local_fields) { $self->_init_field($field); } foreach my $form ($self->forms) { $form->init_fields; } } else { foreach my $field ($self->fields) { $self->_init_field($field); } } } sub _init_field { my($self, $field) = @_; my $on_off = $field->isa('Rose::HTML::Form::Field::OnOff'); my $name = $field->name; my $moniker = $field->moniker; my $name_attr = $field->html_attr('name'); $Debug && warn "INIT FIELD $name ($name_attr)\n"; my $name_exists = $self->param_exists($name); my $moniker_exists = $self->param_exists($moniker); my $name_attr_exists = $self->param_exists($name_attr); if(!$name_exists && $field->isa('Rose::HTML::Form::Field::Compound')) { foreach my $moniker ($field->field_monikers) { $self->_init_field($field->field($moniker)); } } else { return unless($name_exists || $name_attr_exists || $moniker_exists || $on_off); if($field->isa('Rose::HTML::Form::Field::Group')) { if($name_exists) { $Debug && warn "$field->input_value(", $self->param($name), ")\n"; $field->input_value($self->param($name)); } elsif($moniker_exists) { $Debug && warn "$field->input_value(", $self->param($moniker), ")\n"; $field->input_value($self->param($moniker)); } else { $Debug && warn "$field->input_value(", $self->param($name_attr), ")\n"; $field->input_value($self->param($name_attr)); } } else { # Must handle lone checkboxes and radio buttons here if($on_off) { no warnings 'uninitialized'; if($name_exists && $self->param($name) eq $field->html_attr('value')) { $Debug && warn "$self->param($name) = checked\n"; $field->checked(1); } else { if($self->params_exist) { $field->checked(0); } else { # Didn't set anything, so avoid doing pareant un-clearing below return; } } } else { if($name_exists) { $Debug && warn "$field->input_value(", $self->param($name), ")\n"; $field->input_value($self->param($name)); } elsif($moniker_exists) { $Debug && warn "$field->input_value(", $self->param($moniker), ")\n"; $field->input_value($self->param($moniker)); } else { $Debug && warn "$field->input_value(", $self->param($name_attr), ")\n"; $field->input_value($self->param($name_attr)); } } } } my $parent = $field->parent_field; # Ensure that setting the value of a child field makes all its # parent fields "not cleared" while($parent) { $parent->is_cleared(0); $parent = $parent->parent_field; } } sub was_submitted { my($self) = shift; foreach my $field ($self->fields) { return 1 if($self->param_exists_for_field($field->name)); } return 0; } sub start_html { my($self) = shift; return '<' . ref($self)->html_element . $self->html_attrs_string() . '>'; } *start_xhtml = \&start_html; sub start_multipart_html { my($self) = shift; $self->html_attr(enctype => 'multipart/form-data'); return $self->start_html; } *start_multipart_xhtml = \&start_multipart_html; sub end_html { '' } sub end_multipart_html { '' } *end_xhtml = \&end_html; *end_multipart_xhtml = \&end_multipart_html; sub object_from_form { my($self) = shift; my($class, $object); if(@_ == 1) { $class = shift; if(ref $class) { $object = $class; $class = ref $object; } } elsif(@_) { my %args = @_; $class = $args{'class'}; $object = $args{'object'}; } else { croak "Missing required object class argument"; } $object ||= $class->new(); # Special handling of boolean columns for RDBO if($object->isa('Rose::DB::Object')) { my $meta = $object->meta; FIELD: foreach my $field ($self->fields) { my $name = $field->local_name; # When more than one field has the same local_name(), fields closer # to the parent form take precedence. my $check_name = $field->name; # Remove the form name context, if any if(defined(my $form_name_context = $self->form_name_context)) { $check_name =~ s/^$form_name_context//; } if($check_name ne $name) { while($check_name =~ s/(^.+$FF_SEPARATOR_RE|^)[^$FF_SEPARATOR_RE]+$FF_SEPARATOR_RE([^$FF_SEPARATOR_RE]+)$/$1$2/) { next FIELD if($self->field($check_name)); } } if($object->can($name)) { # Checkboxes setting boolean columns if($field->isa('Rose::HTML::Form::Field::Checkbox') && $meta->column($name) && $meta->column($name)->type eq 'boolean') { #$Debug && warn "$class object $name(", $field->is_on, ")"; $object->$name($field->is_on); } else # everything else { #$Debug && warn "$class object $name(", $field->internal_value, ")"; $object->$name($field->internal_value); } } } } else { FIELD: foreach my $field ($self->fields) { my $name = $field->local_name; # When more than one field has the same local_name(), fields closer # to the parent form take precedence. my $check_name = $field->name; # Remove the form name context, if any if(defined(my $form_name_context = $self->form_name_context)) { $check_name =~ s/^$form_name_context//; } if($check_name ne $name) { while($check_name =~ s/(^.+$FF_SEPARATOR_RE|^)[^$FF_SEPARATOR_RE]+$FF_SEPARATOR_RE([^$FF_SEPARATOR_RE]+)$/$1$2/) { next FIELD if($self->field($check_name)); } } if($object->can($name)) { #$Debug && warn "$class object $name(", $field->internal_value, ")"; $object->$name($field->internal_value); } } } return $object; } *init_object_with_form = \&object_from_form; sub init_with_object { my($self, $object) = @_; croak "Missing required object argument" unless($object); $self->clear(); foreach my $field ($self->fields) { my $name = $field->local_name; if($object->can($name)) { #$Debug && warn "field($name) = $object->$name = ", $object->$name(); $field->input_value(scalar $object->$name()); } } } sub clear { my($self) = shift; $self->clear_fields; $self->clear_forms; $self->error(undef); } sub reset { my($self) = shift; $self->reset_fields; $self->reset_forms; $self->error(undef); } sub init_form_rank_counter { 1 } sub next_form_rank { my($self) = shift; my $rank = 1; foreach my $form ($self->forms) { $rank = $form->rank + 1 if($form->rank >= $rank); } return $rank; } # XXX: Remove when form_rank_counter is removed sub increment_form_rank_counter { my($self) = shift; my $rank = $self->form_rank_counter; $self->form_rank_counter($rank + 1); return $rank; } sub repeatable_form { my($self) = shift; # Set form if(@_ > 1) { my($name, $form) = (shift, shift); $self->delete_repeatable_form($name); return $self->add_repeatable_form($name => $form); } my $form = $self->form(@_) or return undef; return undef unless($form->is_repeatable); return $form; } sub repeatable_forms { my($self) = shift; if(@_) { $self->delete_repeatable_forms; $self->add_repeatable_forms(@_); return unless(defined wantarray); } return wantarray ? (grep { $_->is_repeatable_form } $self->forms(@_)) : [ grep { $_->is_repeatable_form } $self->forms(@_) ]; } sub add_repeatable_forms { my($self) = shift; my @form_args; while(@_) { my $arg = shift; if(UNIVERSAL::isa($arg, 'Rose::HTML::Form')) { push(@form_args, $arg->form_name => { form => $arg, repeatable => undef, }); } elsif(!ref $arg) { if(UNIVERSAL::isa($_[0], 'Rose::HTML::Form')) { my $form = shift; push(@form_args, $arg => { form => $form, repeatable => undef, }); } elsif(ref $_[0] eq 'HASH') { my $spec = shift; $spec->{'repeatable'} = undef unless(exists $spec->{'repeatable'}); push(@form_args, $arg => $spec); } else { croak "Invalid argument pair passed to add_repeatable_forms() - $arg, $_[0]"; } } else { croak "Invalid argument passed to add_repeatable_forms() - $arg"; } } return $self->add_forms(@form_args); } sub add_repeatable_form { shift->add_repeatable_forms(@_) } sub form_depth { my($self) = shift; if(@_) { return $self->{'form_depth'} = shift; } return $self->{'form_depth'} if(defined $self->{'form_depth'}); my $depth = 0; my $form = $self; $depth++ while($form = $form->parent_form); return $self->{'form_depth'} = $depth; } sub add_forms { my($self) = shift; my @added_forms; my $next_rank = $self->next_form_rank; while(@_) { my $arg = shift; my($name, $form); if(UNIVERSAL::isa($arg, 'Rose::HTML::Form')) { $form = $arg; if(Scalar::Util::refaddr($form) eq Scalar::Util::refaddr($self)) { croak "Cannot nest a form within itself"; } $name = $form->form_name; croak "Cannot add form $form without a name" unless(defined $name); croak "Cannot add form with the same name as an existing field: $name" if($self->field($name)); unless(defined $form->rank) { $self->increment_form_rank_counter; # XXX: Remove when form_rank_counter is removed $form->rank($next_rank++); } } else { $name = $arg; $form = shift; croak "Cannot add form with the same name as an existing field: $name" if($self->field($name)); if(UNIVERSAL::isa($form, 'Rose::HTML::Form')) { if(Scalar::Util::refaddr($form) eq Scalar::Util::refaddr($self)) { croak "Cannot nest a form within itself"; } # Manually propagate the empty_is_ok attribute to sub-forms, but only if it's set $form->empty_is_ok(1) if($self->empty_is_ok); } elsif(ref $form eq 'HASH') { unless(exists $form->{'repeatable'}) { croak "Missing key 'repeatable' in hash reference specification for form named '$name'"; } my $repeat_spec = $form; if(ref $form->{'repeatable'}) { @$repeat_spec{keys %{$form->{'repeatable'}}} = values %{$form->{'repeatable'}}; } else { $repeat_spec->{'default_count'} = $form->{'repeatable'} unless(exists $repeat_spec->{'default_count'}); } delete $form->{'repeatable'}; $repeat_spec->{'prototype_form_spec'} = delete $repeat_spec->{'spec'} if($repeat_spec->{'spec'}); $repeat_spec->{'prototype_form_spec'} = delete $repeat_spec->{'form_spec'} if($repeat_spec->{'form_spec'}); $repeat_spec->{'prototype_form_class'} = delete $repeat_spec->{'class'} if($repeat_spec->{'class'}); $repeat_spec->{'prototype_form_class'} = delete $repeat_spec->{'form_class'} if($repeat_spec->{'form_class'}); $repeat_spec->{'prototype_form'} = delete $repeat_spec->{'form'} if($repeat_spec->{'form'}); $form = ref($self)->object_type_class_loaded('repeatable form')->new(%$repeat_spec); # Manually propagate the empty_is_ok attribute to sub-forms, but only if it's set if($repeat_spec->{'empty_is_ok'} || $self->empty_is_ok) { $form->empty_is_ok(1); } } else { Carp::croak "Not a Rose::HTML::Form object: $form"; } $form->form_name($name); unless(defined $form->rank) { $self->increment_form_rank_counter; # XXX: Remove when form_rank_counter is removed $form->rank($next_rank++); } } if(index($name, FF_SEPARATOR) >= 0) { my($parent_form, $local_name) = $self->choose_parent_form($name); $form->form_name($local_name); $form->parent_form($parent_form); $parent_form->add_form($local_name => $form); } else { $form->parent_form($self); $self->{'forms'}{$name} = $form; } push(@added_forms, $form); } my $depth = $self->form_depth + 1; foreach my $form (@added_forms) { if($form->recursive_init_fields || $form->isa('Rose::HTML::Form::Repeatable')) { $self->recursive_init_fields(1); } $form->form_depth($depth); $form->resync_field_names; } $self->_clear_form_generated_values; $self->resync_fields_by_name; return unless(defined wantarray); return @added_forms; } *add_form = \&add_forms; sub resync_field_names { my($self) = shift; foreach my $field ($self->fields) { $field->resync_name; } foreach my $form ($self->forms) { $form->resync_field_names; } } sub resync_fields_by_name { my($self) = shift; $self->{'fields_by_name'} = {}; foreach my $field ($self->fields) { $self->{'fields_by_name'}{$field->name} = $field; } } sub compare_forms { my($self, $one, $two) = @_; no warnings 'uninitialized'; return $one->form_depth <=> $two->form_depth || $one->rank <=> $two->rank; } sub forms { my($self) = shift; if(@_) { $self->delete_forms; $self->add_forms(@_); return unless(defined wantarray); } if(my $forms = $self->{'form_list'}) { return wantarray ? @$forms : $forms; } my $forms = $self->{'forms'}; $self->{'form_list'} = [ grep { defined } map { $forms->{$_} } $self->form_names ]; return wantarray ? @{$self->{'form_list'}} : $self->{'form_list'}; } sub form_names { my($self) = shift; if(my $names = $self->{'form_names'}) { return wantarray ? @$names : $names; } my @info; while(my($name, $form) = each %{$self->{'forms'}}) { push(@info, [ $name, $form ]); } $self->{'form_names'} = [ map { $_->[0] } sort { $self->compare_forms($a->[1], $b->[1]) } @info ]; return wantarray ? @{$self->{'form_names'}} : $self->{'form_names'}; } sub delete_repeatable_forms { my($self) = shift; foreach my $form (grep { $_->is_repeatable_form } $self->forms) { delete $self->{'forms'}{$form->form_name}; } $self->_clear_form_generated_values; return; } sub delete_repeatable_form { my($self, $name) = @_; $name = $name->form_name if(UNIVERSAL::isa($name, 'Rose::HTML::Form')); if(exists $self->{'forms'}{$name} && $self->{'forms'}{$name}->is_repeatable_form) { my $form = delete $self->{'forms'}{$name}; $self->_clear_form_generated_values; return $form; } return undef; } sub delete_repeatable_fields { my($self) = shift; foreach my $form (grep { $_->is_repeatable_field } $self->forms) { delete $self->{'forms'}{$form->form_name}; } $self->_clear_form_generated_values; return; } sub delete_repeatable_field { my($self, $name) = @_; $name = $name->form_name if(UNIVERSAL::isa($name, 'Rose::HTML::Form')); if(exists $self->{'forms'}{$name} && $self->{'forms'}{$name}->is_repeatable_field) { $self->_clear_form_generated_values; return delete $self->{'forms'}{$name}; } return undef; } sub delete_forms { my($self) = shift; # Leave the repeatable fields which are implemented as a special case of repeatable forms foreach my $form (grep { !$_->is_repeatable_field } $self->forms) { delete $self->{'forms'}{$form->form_name}; } $self->form_rank_counter(undef); # XXX: Remove when form_rank_counter is removed $self->_clear_form_generated_values; return; } sub delete_form { my($self, $name) = @_; $name = $name->form_name if(UNIVERSAL::isa($name, 'Rose::HTML::Form')); if(exists $self->{'forms'}{$name}) { my $form = delete $self->{'forms'}{$name}; $self->_clear_form_generated_values; return $form; } return undef; } sub clear_forms { my($self) = shift; foreach my $form ($self->forms) { $form->clear(); } } sub reset_forms { my($self) = shift; foreach my $form ($self->forms) { $form->reset(); } } sub _clear_form_generated_values { my($self) = shift; $self->{'form_list'} = undef; $self->{'form_names'} = undef; $self->{'form_depth'} = undef; $self->_clear_field_generated_values; } sub form_name { my($self) = shift; return $self->{'form_name'} unless(@_); my $old_name = $self->{'form_name'}; my $name = $self->{'form_name'} = shift; my %forms; if(my $parent_form = $self->parent_form) { if(defined $old_name && defined $name && $name ne $old_name) { $parent_form->delete_form($old_name); $parent_form->add_form($name => $self); } } return $name; } sub local_field { my($self, $name) = (shift, shift); if(my $field = shift) { $field = $self->make_field($name, $field); $field->parent_form($self); no warnings 'uninitialized'; $field->name($name) unless(length $field->name); $field->moniker($name); $self->{'fields_by_name'}{$field->name} = $field; return $self->{'fields'}{$name} = $field; } return $self->{'fields'}{$name} || $self->{'fields_by_name'}{$name}; } sub local_fields { my($self) = shift; return values %{ $self->{'fields'} || {} }; } sub delete_fields { my($self) = shift; $self->_clear_field_generated_values; $self->{'fields'} = {}; $self->{'fields_by_name'} = {}; $self->delete_repeatable_fields; $self->field_rank_counter(undef); return; } sub delete_field { my($self, $name) = @_; $name = $name->name if(UNIVERSAL::isa($name, 'Rose::HTML::Form::Field')); $self->_clear_field_generated_values; my $field1 = delete $self->{'fields'}{$name}; my $field2 = delete $self->{'fields_by_name'}{$name}; return $field1 || $field2; } sub field { my($self, $name) = (shift, shift); return $self->{'field_cache'}{$name} if($self->{'field_cache'}{$name}); my $sep_pos; # Non-hierarchical name if(($sep_pos = index($name, FF_SEPARATOR)) < 0) { return $self->{'field_cache'}{$name} = $self->local_field($name, @_); } # First check if it's a local compound field my $prefix = substr($name, 0, $sep_pos); my $rest = substr($name, $sep_pos + 1); my $field = $self->field($prefix); if(UNIVERSAL::isa($field, 'Rose::HTML::Form::Field::Compound')) { $field = $field->field($rest); return ($self->{'field_cache'}{$name} = $field) if($field); } my($parent_form, $local_name) = $self->find_parent_form($name); return undef unless($parent_form); return $self->{'field_cache'}{$name} = $parent_form->field($local_name, @_); } sub fields { my($self) = shift; if(@_) { $self->delete_fields; $self->add_fields(@_); } if(my $fields = $self->{'field_list'}) { return wantarray ? @$fields : $fields; } my $fields = $self->{'fields'}; my $fields_by_name = $self->{'fields_by_name'}; $self->{'field_list'} = [ grep { defined } map { if(/$FF_SEPARATOR_RE([^$FF_SEPARATOR_RE]+)/o) { $self->field($_) || $fields->{$1} || $fields_by_name->{$1}; } else { $fields->{$_} || $fields_by_name->{$_} || $self->field($_); } } $self->field_monikers ]; return wantarray ? @{$self->{'field_list'}} : $self->{'field_list'}; } sub fields_depth_first { my($self) = shift; my @fields = sort { $a->rank <=> $b->rank } $self->local_fields; foreach my $form ($self->forms) { push(@fields, $form->fields_depth_first); } return wantarray ? @fields : \@fields; } sub field_monikers { my($self) = shift; if(my $names = $self->{'field_monikers'}) { return wantarray ? @$names : $names; } my @info; $self->_find_field_info($self, \@info); $self->{'field_monikers'} = [ map { $_->[2] } sort { $self->compare_forms($a->[0], $b->[0]) || $self->compare_fields($a->[1], $b->[1]) } @info ]; return wantarray ? @{$self->{'field_monikers'}} : $self->{'field_monikers'}; } sub field_names { shift->field_monikers(@_) } sub _find_field_info { my($self, $form, $list) = @_; while(my($name, $field) = each %{$form->{'fields'}}) { push(@$list, [ $form, $field, $field->fq_moniker ]); } foreach my $sub_form ($form->forms) { $form->_find_field_info($sub_form, $list); } } sub find_parent_form { my($self, $name) = @_; # Non-hierarchical name if(index($name, FF_SEPARATOR) < 0) { return $self->local_form($name) ? ($self, $name) : undef; } my $parent_form; while($name =~ s/^([^$FF_SEPARATOR_RE]+)$FF_SEPARATOR_RE//o) { my $parent_name = $1; last if($parent_form = $self->local_form($parent_name)); } unless(defined $parent_form) { # Maybe this form ($self) is the parent? return ($self, $name) if($self->local_field($name)); return undef; } return wantarray ? ($parent_form, $name) : $parent_form; } sub choose_parent_form { my($self, $name) = @_; # Non-hierarchical name if(index($name, FF_SEPARATOR) < 0) { return wantarray ? ($self, $name) : $self; } my($parent_form, $local_name); while($name =~ s/^(.+)$FF_SEPARATOR_RE([^$FF_SEPARATOR_RE]+)$//o) { $local_name = $2; last if($parent_form = $self->form($1)); } return wantarray ? ($parent_form, $local_name) : $parent_form; } sub fq_form_name { my($self) = shift; return $self->form_name unless($self->parent_form); my @parts; my $form = $self; while(my $parent_form = $form->parent_form) { unshift(@parts, $form->form_name); $form = $parent_form; } return @parts ? join(FF_SEPARATOR, @parts) : ''; } sub form_name_context { my($self) = shift; return undef unless($self->parent_form); my @context; my $form = $self; for(;;) { last unless($form->parent_form); unshift(@context, $form->form_name); $form = $form->parent_form; } return join(FF_SEPARATOR, @context) . FF_SEPARATOR; } sub local_form { my($self, $name) = @_; return $self->{'forms'}{$name} if(exists $self->{'forms'}{$name}); return undef; } sub form { my($self, $name) = (shift, shift); # Set form if(@_) { my $form = shift; $self->delete_form($name); return $self->add_form($name => $form); } # Local form? if(my $form = $self->local_form($name)) { return $form; } # Look up nested form my($parent_form, $local_name) = $self->find_parent_form($name); return undef unless(defined $parent_form); return $parent_form->form($local_name); } sub _html_table { my($self, %args) = @_; my $xhtml = delete $args{'_xhtml'} ? 'xhtml' : 'html'; my $xhtml_field = "${xhtml}_field"; my $xhtml_label = "${xhtml}_label"; my $max_button_depth = exists $args{'max_button_depth'} ? $args{'max_button_depth'} : 1; $args{'class'} = defined $args{'class'} ? "$args{'class'} form" : 'form'; $args{'tr'} ||= {}; $args{'td'} ||= {}; $args{'table'}{'class'} = defined $args{'table'}{'class'} ? "$args{'table'}{'class'} form" : defined $args{'class'} ? $args{'class'} : undef; $args{'tr'}{'class'} = defined $args{'tr'}{'class'} ? "$args{'tr'}{'class'} field" : 'field'; my $html = join('', map { $_->$xhtml() } $self->pre_children); $html .= join("\n", map { $_->$xhtml_field() } grep { $_->isa('Rose::HTML::Form::Field::Hidden') } $self->fields); $html .= "\n\n" if($html); $html .= '
| ' . $field->$xhtml_field . " | \n|
| $label | \n"; $args{'td'}{'class'} =~ s/(?:^| )label$//; $args{'td'}{'class'} = $args{'td'}{'class'} ? "$args{'td'}{'class'} field" : 'field'; $html .= '' . $field->$xhtml() . " | \n
| ' . join(' ', map { $_->$xhtml_field() } @buttons) . " | \n