package HTML::FormFu; use strict; use base 'HTML::FormFu::base'; use HTML::FormFu::Attribute qw( mk_attrs mk_attr_accessors mk_inherited_accessors mk_output_accessors mk_inherited_merging_accessors mk_item_accessors mk_accessors ); use HTML::FormFu::Constants qw( $EMPTY_STR ); use HTML::FormFu::Constraint; use HTML::FormFu::Exception; use HTML::FormFu::FakeQuery; use HTML::FormFu::Filter; use HTML::FormFu::Inflator; use HTML::FormFu::Localize; use HTML::FormFu::ObjectUtil qw( :FORM_AND_BLOCK :FORM_AND_ELEMENT populate form load_config_file load_config_filestem clone stash constraints_from_dbic parent get_nested_hash_value set_nested_hash_value delete_nested_hash_key nested_hash_key_exists ); use HTML::FormFu::Util qw( DEBUG DEBUG_PROCESS DEBUG_CONSTRAINTS debug require_class _get_elements xml_escape split_name _parse_args process_attrs _filter_components ); use List::Util qw( first ); use List::MoreUtils qw( any none uniq ); use Scalar::Util qw( blessed refaddr weaken ); use Storable qw( dclone ); use Regexp::Copy; use Carp qw( croak ); use overload ( 'eq' => sub { refaddr $_[0] eq refaddr $_[1] }, 'ne' => sub { refaddr $_[0] ne refaddr $_[1] }, '==' => sub { refaddr $_[0] eq refaddr $_[1] }, '!=' => sub { refaddr $_[0] ne refaddr $_[1] }, '""' => sub { return shift->render }, 'bool' => sub {1}, 'fallback' => 1, ); __PACKAGE__->mk_attrs(qw( attributes )); __PACKAGE__->mk_attr_accessors(qw( id action enctype method )); __PACKAGE__->mk_item_accessors( qw( indicator filename query_type force_error_message localize_class query input _auto_fieldset _elements _processed_params _output_processors tt_module nested_name nested_subscript default_model tmp_upload_dir params_ignore_underscore _plugins ) ); __PACKAGE__->mk_accessors( qw( javascript javascript_src languages submitted _valid_names _models ) ); __PACKAGE__->mk_output_accessors(qw( form_error_message )); __PACKAGE__->mk_inherited_accessors( qw( auto_id auto_label auto_error_class auto_error_message auto_constraint_class auto_inflator_class auto_validator_class auto_transformer_class render_method render_processed_value force_errors repeatable_count config_file_path locale ) ); __PACKAGE__->mk_inherited_merging_accessors(qw( tt_args config_callback )); *elements = \&element; *constraints = \&constraint; *filters = \&filter; *deflators = \&deflator; *inflators = \&inflator; *validators = \&validator; *transformers = \&transformer; *output_processors = \&output_processor; *loc = \&localize; *plugins = \&plugin; *add_plugins = \&add_plugin; our $VERSION = '0.05001'; $VERSION = eval $VERSION; Class::C3::initialize(); sub new { my ( $class, $argument_ref ) = @_; my %defaults = ( _elements => [], _output_processors => [], _valid_names => [], _plugins => [], _models => [], _processed_params => {}, input => {}, stash => {}, action => '', method => 'post', filename => 'form', default_args => {}, render_method => 'string', tt_args => {}, tt_module => 'Template', query_type => 'CGI', languages => ['en'], default_model => 'DBIC', localize_class => 'HTML::FormFu::I18N', auto_error_class => 'error_%s_%t', auto_error_message => 'form_%s_%t', ); my $self = bless {}, $class; $self->populate( \%defaults ); if ($argument_ref) { $self->populate($argument_ref); } return $self; } sub auto_fieldset { my ( $self, $element_ref ) = @_; # if there's no arg, just return whether there's an auto_fieldset already return $self->_auto_fieldset if !$element_ref; # if the argument isn't a reference, assume it's just a "1" meaning true, # and use an empty hashref if ( !ref $element_ref ) { $element_ref = {}; } $element_ref->{type} = 'Fieldset'; $self->element($element_ref); $self->_auto_fieldset(1); return $self; } sub default_values { my ( $self, $default_ref ) = @_; for my $field ( @{ $self->get_fields } ) { my $name = $field->nested_name; next if !defined $name; next if !exists $default_ref->{$name}; $field->default( $default_ref->{$name} ); } return $self; } sub model { my ( $self, $model_name ) = @_; $model_name ||= $self->default_model; # search models already loaded for my $model ( @{ $self->_models } ) { return $model if $model->type =~ /\Q$model_name\E$/; } # class not found, try require-ing it my $class = $model_name =~ s/^\+// ? $model_name : "HTML::FormFu::Model::$model_name"; require_class($class); my $model = $class->new( { type => $model_name, parent => $self, } ); push @{ $self->_models }, $model; return $model; } sub model_class { my $self = shift; warn "model_class() method deprecated and is provided for compatibilty only, " . "and will be removed: use default_model instead\n"; return $self->default_model(@_); } sub defaults_from_model { my $self = shift; warn "defaults_from_model() method deprecated and is provided for compatibility only, " . "and will be removed: use \$form->model->default_values() instead\n"; return $self->model->default_values(@_); } sub save_to_model { my $self = shift; warn "save_to_model() method deprecated and is provided for compatibility only, " . "and will be removed: use \$form->model->update() instead\n"; return $self->model->update(@_); } sub process { my ( $self, $query ) = @_; $self->input( {} ); $self->_processed_params( {} ); $self->_valid_names( [] ); $self->clear_errors; $query ||= $self->query; if ( defined $query && !blessed($query) ) { $query = HTML::FormFu::FakeQuery->new( $self, $query ); } # save it for further calls to process() if ($query) { DEBUG && debug( QUERY => $query ); $self->query($query); } # run all elements pre_process() methods for my $elem ( @{ $self->get_elements } ) { $elem->pre_process; } # run all plugins pre_process() methods for my $plugin ( @{ $self->get_plugins } ) { $plugin->pre_process; } # run all elements process() methods for my $elem ( @{ $self->get_elements } ) { $elem->process; } # run all plugins process() methods for my $plugin ( @{ $self->get_plugins } ) { $plugin->process; } my $submitted; if ( defined $query ) { eval { my @params = $query->param }; croak "Invalid query object: $@" if $@; $submitted = $self->_submitted($query); } DEBUG_PROCESS && debug( SUBMITTED => $submitted ); $self->submitted($submitted); if ($submitted) { my %input; my @params = $query->param; for my $field ( @{ $self->get_fields } ) { my $name = $field->nested_name; next if !defined $name; next if none { $name eq $_ } @params; if ( $field->nested ) { # call in list context so we know if there's more than 1 value my @values = $query->param($name); my $value = @values > 1 ? \@values : $values[0]; $self->set_nested_hash_value( \%input, $name, $value ); } else { my @values = $query->param($name); $input{$name} = @values > 1 ? \@values : $values[0]; } } DEBUG && debug( INPUT => \%input ); # run all field process_input methods for my $field ( @{ $self->get_fields } ) { $field->process_input( \%input ); } $self->input( \%input ); $self->_process_input; } # run all plugins post_process methods for my $elem ( @{ $self->get_elements } ) { $elem->post_process; } for my $plugin ( @{ $self->get_plugins } ) { $plugin->post_process; } return; } sub _submitted { my ( $self, $query ) = @_; my $indicator = $self->indicator; my $code; if ( defined($indicator) && ref $indicator ne 'CODE' ) { DEBUG_PROCESS && debug( INDICATOR => $indicator ); $code = sub { return defined $query->param($indicator) }; } elsif ( !defined $indicator ) { my @names = uniq grep {defined} map { $_->nested_name } @{ $self->get_fields }; DEBUG_PROCESS && debug( 'no indicator, checking fields...' => \@names ); $code = sub { grep { defined $query->param($_) } @names; }; } else { $code = $indicator; } return $code->( $self, $query ); } sub _process_input { my ($self) = @_; $self->_build_params; $self->_process_file_uploads; $self->_filter_input; $self->_constrain_input; $self->_inflate_input if !@{ $self->get_errors }; $self->_validate_input if !@{ $self->get_errors }; $self->_transform_input if !@{ $self->get_errors }; $self->_build_valid_names; return; } sub _build_params { my ($self) = @_; my $input = $self->input; my %params; for my $field ( @{ $self->get_fields } ) { my $name = $field->nested_name; next if !defined $name; next if exists $params{$name}; next if !$self->nested_hash_key_exists( $self->input, $name ) && !$field->default_empty_value; my $input = $self->get_nested_hash_value( $self->input, $name ); if ( ref $input eq 'ARRAY' ) { # can't clone upload filehandles # so create new arrayref of values $input = [@$input]; } elsif ( !defined $input && $field->default_empty_value ) { $input = ''; } $self->set_nested_hash_value( \%params, $name, $input, $name ); } $self->_processed_params( \%params ); DEBUG_PROCESS && debug( 'PROCESSED PARAMS' => \%params ); return; } sub _process_file_uploads { my ($self) = @_; my @names = uniq grep {defined} map { $_->nested_name } grep { $_->isa('HTML::FormFu::Element::File') } @{ $self->get_fields }; if (@names) { my $query_class = $self->query_type; if ( $query_class !~ /^\+/ ) { $query_class = "HTML::FormFu::QueryType::$query_class"; } require_class($query_class); my $params = $self->_processed_params; my $input = $self->input; for my $name (@names) { next if !$self->nested_hash_key_exists( $input, $name ); my $values = $query_class->parse_uploads( $self, $name ); $self->set_nested_hash_value( $params, $name, $values ); } } return; } sub _filter_input { my ($self) = @_; my $params = $self->_processed_params; for my $filter ( @{ $self->get_filters } ) { my $name = $filter->nested_name; next if !defined $name; next if !$self->nested_hash_key_exists( $params, $name ); $filter->process( $self, $params ); } return; } sub _constrain_input { my ($self) = @_; my $params = $self->_processed_params; for my $constraint ( @{ $self->get_constraints } ) { DEBUG_CONSTRAINTS && debug( 'FIELD NAME' => $constraint->field->nested_name, 'CONSTRAINT TYPE' => $constraint->type, ); my @errors = eval { $constraint->process($params) }; DEBUG_CONSTRAINTS && debug( ERRORS => \@errors ); DEBUG_CONSTRAINTS && debug( '$@' => $@ ); if ( blessed $@ && $@->isa('HTML::FormFu::Exception::Constraint') ) { push @errors, $@; } elsif ($@) { push @errors, HTML::FormFu::Exception::Constraint->new; } for my $error (@errors) { if ( !$error->parent ) { $error->parent( $constraint->parent ); } if ( !$error->constraint ) { $error->constraint($constraint); } $error->parent->add_error($error); } } return; } sub _inflate_input { my ($self) = @_; my $params = $self->_processed_params; for my $inflator ( @{ $self->get_inflators } ) { my $name = $inflator->nested_name; next if !defined $name; next if !$self->nested_hash_key_exists( $params, $name ); next if any {defined} @{ $inflator->parent->get_errors }; my $value = $self->get_nested_hash_value( $params, $name ); my @errors; ( $value, @errors ) = eval { $inflator->process($value) }; if ( blessed $@ && $@->isa('HTML::FormFu::Exception::Inflator') ) { push @errors, $@; } elsif ($@) { push @errors, HTML::FormFu::Exception::Inflator->new; } for my $error (@errors) { $error->parent( $inflator->parent ) if !$error->parent; $error->inflator($inflator) if !$error->inflator; $error->parent->add_error($error); } $self->set_nested_hash_value( $params, $name, $value ); } return; } sub _validate_input { my ($self) = @_; my $params = $self->_processed_params; for my $validator ( @{ $self->get_validators } ) { my $name = $validator->nested_name; next if !defined $name; next if !$self->nested_hash_key_exists( $params, $name ); next if any {defined} @{ $validator->parent->get_errors }; my @errors = eval { $validator->process($params) }; if ( blessed $@ && $@->isa('HTML::FormFu::Exception::Validator') ) { push @errors, $@; } elsif ($@) { push @errors, HTML::FormFu::Exception::Validator->new; } for my $error (@errors) { $error->parent( $validator->parent ) if !$error->parent; $error->validator($validator) if !$error->validator; $error->parent->add_error($error); } } return; } sub _transform_input { my ($self) = @_; my $params = $self->_processed_params; for my $transformer ( @{ $self->get_transformers } ) { my $name = $transformer->nested_name; next if !defined $name; next if !$self->nested_hash_key_exists( $params, $name ); next if any {defined} @{ $transformer->parent->get_errors }; my $value = $self->get_nested_hash_value( $params, $name ); my (@errors) = eval { $transformer->process( $value, $params ) }; if ( blessed $@ && $@->isa('HTML::FormFu::Exception::Transformer') ) { push @errors, $@; } elsif ($@) { push @errors, HTML::FormFu::Exception::Transformer->new; } for my $error (@errors) { $error->parent( $transformer->parent ) if !$error->parent; $error->transformer($transformer) if !$error->transformer; $error->parent->add_error($error); } } return; } sub _build_valid_names { my ($self) = @_; my $params = $self->_processed_params; my $skip_private = $self->params_ignore_underscore; my @errors = $self->has_errors; my @names; my %non_param; for my $field ( @{ $self->get_fields } ) { my $name = $field->nested_name; next if !defined $name; next if $skip_private && $field->name =~ /^_/; if ( $field->non_param ) { $non_param{$name} = 1; } elsif ( $self->nested_hash_key_exists( $params, $name ) ) { push @names, $name; } } push @names, uniq grep { ref $params->{$_} ne 'HASH' } grep { !( $skip_private && /^_/ ) } grep { !exists $non_param{$_} } keys %$params; my %valid; CHECK: for my $name (@names) { for my $error (@errors) { next CHECK if $name eq $error; } $valid{$name}++; } my @valid = keys %valid; $self->_valid_names( \@valid ); return; } sub _hash_keys { my ( $hash, $subscript ) = @_; my @names; for my $key ( keys %$hash ) { if ( ref $hash->{$key} eq 'HASH' ) { push @names, map { $subscript ? "${key}[${_}]" : "$key.$_" } _hash_keys( $hash->{$key}, $subscript ); } elsif ( ref $hash->{$key} eq 'ARRAY' ) { push @names, map { $subscript ? "${key}[${_}]" : "$key.$_" } _array_indices( $hash->{$key}, $subscript ); } else { push @names, $key; } } return @names; } sub _array_indices { my ( $array, $subscript ) = @_; my @names; for my $i ( 0 .. $#{$array} ) { if ( ref $array->[$i] eq 'HASH' ) { push @names, map { $subscript ? "${i}[${_}]" : "$i.$_" } _hash_keys( $array->[$i], $subscript ); } elsif ( ref $array->[$i] eq 'ARRAY' ) { push @names, map { $subscript ? "${i}[${_}]" : "$i.$_" } _array_indices( $array->[$i], $subscript ); } else { push @names, $i; } } return @names; } sub submitted_and_valid { my ($self) = @_; return $self->submitted && !$self->has_errors; } sub params { my ($self) = @_; return {} if !$self->submitted; my @names = $self->valid; my %params; for my $name (@names) { my @values = $self->param($name); if ( @values > 1 ) { $self->set_nested_hash_value( \%params, $name, \@values ); } else { $self->set_nested_hash_value( \%params, $name, $values[0] ); } } return \%params; } sub param { my ( $self, $name ) = @_; croak 'param method is readonly' if @_ > 2; return if !$self->submitted; if ( @_ == 2 ) { return if !$self->valid($name); my $value = $self->get_nested_hash_value( $self->_processed_params, $name ); return if !defined $value; if ( ref $value eq 'ARRAY' ) { return wantarray ? @$value : $value->[0]; } else { return $value; } } # return a list of valid names, if no $name arg return $self->valid; } sub param_value { my ( $self, $name ) = @_; croak 'name parameter required' if @_ != 2; # ignore $form->valid($name) and $form->submitted # this is guaranteed to always return a single value # or undef my $value = $self->get_nested_hash_value( $self->_processed_params, $name ); return ref $value eq 'ARRAY' ? $value->[0] : $value; } sub param_array { my ( $self, $name ) = @_; croak 'name parameter required' if @_ != 2; # guaranteed to always return an arrayref return [] if !$self->valid($name); my $value = $self->get_nested_hash_value( $self->_processed_params, $name ); return [] if !defined $value; return ref $value eq 'ARRAY' ? $value : [$value]; } sub param_list { my ( $self, $name ) = @_; croak 'name parameter required' if @_ != 2; # guaranteed to always return an arrayref return if !$self->valid($name); my $value = $self->get_nested_hash_value( $self->_processed_params, $name ); return if !defined $value; return ref $value eq 'ARRAY' ? @$value : $value; } sub valid { my $self = shift; return if !$self->submitted; my @valid = @{ $self->_valid_names }; if (@_) { my $name = shift; return 1 if any { $name eq $_ } @valid; # not found - see if it's the name of a nested block my $parent; if ( defined $self->nested_name && $self->nested_name eq $name ) { $parent = $self; } else { ($parent) = first { $_->isa('HTML::FormFu::Element::Block') } @{ $self->get_all_elements( { nested_name => $name, } ) }; } if ( defined $parent ) { my $fail = any {defined} map { @{ $_->get_errors } } @{ $parent->get_fields }; return 1 if !$fail; } return; } # return a list of valid names, if no $name arg return @valid; } sub has_errors { my $self = shift; return if !$self->submitted; my @names = map { $_->nested_name } grep { @{ $_->get_errors } } grep { defined $_->nested_name } @{ $self->get_fields }; if (@_) { my $name = shift; return 1 if any {/\Q$name/} @names; return; } # return list of names with errors, if no $name arg return @names; } sub add_valid { my ( $self, $key, $value ) = @_; croak 'add_valid requires arguments ($key, $value)' if @_ != 3; $self->set_nested_hash_value( $self->input, $key, $value ); $self->set_nested_hash_value( $self->_processed_params, $key, $value ); if ( none { $_ eq $key } @{ $self->_valid_names } ) { push @{ $self->_valid_names }, $key; } return $value; } sub _single_plugin { my ( $self, $arg_ref ) = @_; if ( !ref $arg_ref ) { $arg_ref = { type => $arg_ref }; } elsif ( ref $arg_ref eq 'HASH' ) { # shallow clone $arg_ref = {%$arg_ref}; } else { croak 'invalid args'; } my $type = delete $arg_ref->{type}; my @return; my @names = map { ref $_ ? @$_ : $_ } grep {defined} ( delete $arg_ref->{name}, delete $arg_ref->{names} ); if (@names) { # add plugins to appropriate fields for my $x (@names) { for my $field ( @{ $self->get_fields( { nested_name => $x } ) } ) { my $new = $field->_require_plugin( $type, $arg_ref ); push @{ $field->_plugins }, $new; push @return, $new; } } } else { # add plugin directly to form my $new = $self->_require_plugin( $type, $arg_ref ); push @{ $self->_plugins }, $new; push @return, $new; } return @return; } sub render { my $self = shift; my $plugins = $self->get_plugins; for my $plugin (@$plugins) { $plugin->render; } my $output = $self->next::method(@_); for my $plugin (@$plugins) { $plugin->post_render( \$output ); } return $output; } sub render_data { my ( $self, $args ) = @_; my $render = $self->render_data_non_recursive( { elements => [ map { $_->render_data } @{ $self->_elements } ], $args ? %$args : (), } ); return $render; } sub render_data_non_recursive { my ( $self, $args ) = @_; my %render = ( filename => $self->filename, javascript => $self->javascript, javascript_src => $self->javascript_src, attributes => xml_escape( $self->attributes ), stash => $self->stash, $args ? %$args : (), ); $render{form} = \%render; weaken( $render{form} ); $render{object} = $self; if ($self->force_error_message || ( $self->has_errors && defined $self->form_error_message ) ) { $render{form_error_message} = xml_escape( $self->form_error_message ); } return \%render; } sub string { my ( $self, $args_ref ) = @_; $args_ref ||= {}; # start_form template my $render_ref = exists $args_ref->{render_data} ? $args_ref->{render_data} : $self->render_data_non_recursive; my $html = sprintf "
\n"; return $html; } sub start { my ($self) = @_; return $self->tt( { filename => 'start_form', render_data => $self->render_data_non_recursive, } ); } sub end { my ($self) = @_; return $self->tt( { filename => 'end_form', render_data => $self->render_data_non_recursive, } ); } sub hidden_fields { my ($self) = @_; return join $EMPTY_STR, map { $_->render } @{ $self->get_fields( { type => 'Hidden' } ) }; } sub output_processor { my ( $self, $arg ) = @_; my @return; if ( ref $arg eq 'ARRAY' ) { push @return, map { $self->_single_output_processor($_) } @$arg; } else { push @return, $self->_single_output_processor($arg); } return @return == 1 ? $return[0] : @return; } sub _single_output_processor { my ( $self, $arg ) = @_; if ( !ref $arg ) { $arg = { type => $arg }; } elsif ( ref $arg eq 'HASH' ) { $arg = dclone($arg); } else { croak 'invalid args'; } my $type = delete $arg->{type}; my $new = $self->_require_output_processor( $type, $arg ); push @{ $self->_output_processors }, $new; return $new; } sub _require_output_processor { my ( $self, $type, $opt ) = @_; croak 'required arguments: $self, $type, \%options' if @_ != 3; eval { my %x = %$opt }; croak "options argument must be hash-ref" if $@; my $class = $type; if ( not $class =~ s/^\+// ) { $class = "HTML::FormFu::OutputProcessor::$class"; } $type =~ s/^\+//; require_class($class); my $object = $class->new( { type => $type, parent => $self, } ); # handle default_args my $parent = $self->parent; if ( $parent && exists $parent->default_args->{output_processor}{$type} ) { %$opt = ( %{ $parent->default_args->{output_processer}{$type} }, %$opt ); } $object->populate($opt); return $object; } sub get_output_processors { my $self = shift; my %args = _parse_args(@_); my @x = @{ $self->_output_processors }; if ( exists $args{type} ) { @x = grep { $_->type eq $args{type} } @x; } return \@x; } sub get_output_processor { my $self = shift; my $x = $self->get_output_processors(@_); return @$x ? $x->[0] : (); } 1; __END__ =head1 NAME HTML::FormFu - HTML Form Creation, Rendering and Validation Framework =head1 BETA SOFTWARE There may be API changes required before the 1.0 release. Any incompatible changes will first be discussed on the L