package HTML::FormFu; use strict; our $VERSION = '2.05'; # VERSION use Moose; use MooseX::Attribute::FormFuChained; with 'HTML::FormFu::Role::Render', 'HTML::FormFu::Role::CreateChildren', 'HTML::FormFu::Role::GetProcessors', 'HTML::FormFu::Role::ContainsElements', 'HTML::FormFu::Role::ContainsElementsSharedWithField', 'HTML::FormFu::Role::FormAndBlockMethods', 'HTML::FormFu::Role::FormAndElementMethods', 'HTML::FormFu::Role::FormBlockAndFieldMethods', 'HTML::FormFu::Role::NestedHashUtils', 'HTML::FormFu::Role::Populate', 'HTML::FormFu::Role::CustomRoles'; use HTML::FormFu::Attribute qw( mk_attrs mk_attr_accessors mk_output_accessors mk_inherited_accessors mk_inherited_merging_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 load_config_file load_config_filestem clone stash constraints_from_dbic parent _load_file ); 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 Clone (); use List::Util 1.45 qw( first any none uniq ); use Scalar::Util qw( blessed weaken reftype ); use Carp qw( croak ); use overload ( 'eq' => '_string_equals', '==' => '_object_equals', '""' => sub { return shift->render }, 'bool' => sub {1}, 'fallback' => 1, ); __PACKAGE__->mk_attr_accessors(qw( id action enctype method )); for my $name ( qw( _elements _output_processors _valid_names _plugins _models ) ) { has $name => ( is => 'rw', default => sub { [] }, lazy => 1, isa => 'ArrayRef', ); } has languages => ( is => 'rw', default => sub { ['en'] }, lazy => 1, isa => 'ArrayRef', traits => ['FormFuChained'], ); has input => ( is => 'rw', default => sub { {} }, lazy => 1, isa => 'HashRef', traits => ['FormFuChained'], ); has _processed_params => ( is => 'rw', default => sub { {} }, lazy => 1, isa => 'HashRef', ); has form_error_message_class => ( is => 'rw', default => 'form_error_message', lazy => 1, ); our @MULTIFORM_SHARED = (qw( javascript javascript_src indicator filename query_type force_error_message localize_class tt_module nested_name nested_subscript default_model tmp_upload_dir params_ignore_underscore )); for (@MULTIFORM_SHARED) { has $_ => ( is => 'rw', traits => ['FormFuChained'], ); } has submitted => ( is => 'rw', traits => ['FormFuChained'] ); has query => ( is => 'rw', traits => ['FormFuChained'] ); has _auto_fieldset => ( is => 'rw' ); __PACKAGE__->mk_output_accessors(qw( form_error_message )); *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 $build_defaults = { action => '', method => 'post', filename => 'form', render_method => 'string', tt_args => {}, tt_module => 'Template', query_type => 'CGI', default_model => 'DBIC', localize_class => 'HTML::FormFu::I18N', auto_error_message => 'form_%s_%t', error_tag => 'span', }; sub BUILD { my ( $self, $args ) = @_; $self->populate($build_defaults); return; } 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 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; ## CGI wants you to use $query->multi_param($foo). ## doing so breaks CGI::Simple. So shoosh it up for now. local $CGI::LIST_CONTEXT_WARN = 0; 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, ); $constraint->pre_process; 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; return undef ## no critic (ProhibitExplicitReturnUndef); if !$self->valid($name); # this is guaranteed to always return a single value 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; } around render => sub { my $orig = shift; my $self = shift; my $plugins = $self->get_plugins; for my $plugin (@$plugins) { $plugin->render; } my $output = $self->$orig; 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 ); $render{form_error_message_class} = $self->form_error_message_class; } return \%render; } sub string { my ( $self, $args_ref ) = @_; $args_ref ||= {}; my $html = $self->_string_form_start( $args_ref ); # form template $html .= "\n"; for my $element ( @{ $self->get_elements } ) { # call render, so that child elements can use a different renderer my $element_html = $element->render; # skip Blank fields if ( length $element_html ) { $html .= $element_html . "\n"; } } $html .= $self->_string_form_end( $args_ref ); $html .= "\n"; return $html; } sub _string_form_start { my ( $self, $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 "
"; } sub start { my $self = shift; if ( 'tt' eq $self->render_method ) { return $self->tt( { filename => 'start_form', render_data => $self->render_data_non_recursive, } ); } else { return $self->_string_form_start( @_ ); } } sub end { my $self = shift; if ( 'tt' eq $self->render_method ) { return $self->tt( { filename => 'end_form', render_data => $self->render_data_non_recursive, } ); } else { return $self->_string_form_end( @_ ); } } 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 = Clone::clone($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; croak "options argument must be hash-ref" if reftype($opt) ne 'HASH'; 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] : (); } __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME HTML::FormFu - HTML Form Creation, Rendering and Validation Framework =head1 VERSION version 2.05 =head1 SYNOPSIS Note: These examples make use of L