[libhtml-formhandler-perl] 01/01: [svn-upgrade] new version libhtml-formhandler-perl (0.32001)
Damyan Ivanov
dmn at moszumanska.debian.org
Sat Nov 11 23:03:15 UTC 2017
This is an automated email from the git hooks/post-receive script.
dmn pushed a commit to tag upstream/0.32001
in repository libhtml-formhandler-perl.
commit fab1583a3c34cc648cb78a416ee5772f8da520cf
Author: Antony Gelberg <antony at wayforth.co.uk>
Date: Mon Jun 28 13:15:50 2010 +0000
[svn-upgrade] new version libhtml-formhandler-perl (0.32001)
---
Changes | 28 ++++
MANIFEST | 7 +
META.yml | 4 +-
Makefile.PL | 2 +
lib/HTML/FormHandler.pm | 119 +++++++++++--
lib/HTML/FormHandler/BuildFields.pm | 34 ----
lib/HTML/FormHandler/Field.pm | 100 ++++++++---
lib/HTML/FormHandler/Field/Boolean.pm | 2 +-
lib/HTML/FormHandler/Field/Checkbox.pm | 7 +-
lib/HTML/FormHandler/Field/Display.pm | 24 +++
lib/HTML/FormHandler/Field/Duration.pm | 4 +-
lib/HTML/FormHandler/Field/HtmlArea.pm | 2 +-
lib/HTML/FormHandler/Field/NoValue.pm | 3 +-
lib/HTML/FormHandler/Field/Password.pm | 2 +-
lib/HTML/FormHandler/Field/Repeatable.pm | 49 ++++--
lib/HTML/FormHandler/Field/Result.pm | 17 ++
lib/HTML/FormHandler/Field/Select.pm | 42 ++++-
lib/HTML/FormHandler/Field/Submit.pm | 4 +
lib/HTML/FormHandler/Field/Text.pm | 20 +--
lib/HTML/FormHandler/Field/Upload.pm | 47 +++++-
lib/HTML/FormHandler/I18N.pm | 1 +
lib/HTML/FormHandler/InitResult.pm | 2 +-
lib/HTML/FormHandler/Manual/Cookbook.pod | 186 ++++++++++++++++++++-
lib/HTML/FormHandler/Manual/Intro.pod | 21 ++-
lib/HTML/FormHandler/Render/Simple.pm | 8 +-
lib/HTML/FormHandler/Result.pm | 26 +++
lib/HTML/FormHandler/TraitFor/I18N.pm | 16 +-
lib/HTML/FormHandler/Validate.pm | 10 +-
lib/HTML/FormHandler/Validate/Actions.pm | 24 +++
lib/HTML/FormHandler/Widget/Field/CheckboxGroup.pm | 3 -
.../Widget/Field/Role/HTMLAttributes.pm | 3 +
lib/HTML/FormHandler/Widget/Field/Select.pm | 9 +-
lib/HTML/FormHandler/Widget/Wrapper/Fieldset.pm | 33 ++++
t/compound_field.t | 6 +
t/dates.t | 8 +-
t/defaults.t | 50 +++++-
t/deflate.t | 46 ++++-
t/dependency.t | 32 ++++
t/fields.t | 3 +-
t/filters.t | 3 +-
t/form_handler.t | 1 +
t/form_options.t | 5 +-
t/has_many.t | 42 +++--
t/render.t | 3 +-
t/render_widgets.t | 7 +-
t/result.t | 3 +-
t/types.t | 22 ++-
t/update_fields.t | 42 +++++
t/xt/display.t | 49 ++++++
t/xt/form_errors.t | 48 ++++++
t/xt/init.t | 6 +-
t/xt/locale_data_localize.t | 56 +++++++
t/xt/mb_form.t | 96 +++++++++++
t/xt/posted.t | 59 +++++++
t/xt/upload.t | 52 ++++--
55 files changed, 1278 insertions(+), 220 deletions(-)
diff --git a/Changes b/Changes
index dbe39b9..f5d1f5a 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,31 @@
+0.32001 Fri June 25, 2010
+ Add prereqs for DateTime::Format::Strptime and Email::Valid
+
+0.32000 Fri June 25, 2010
+ Accept arrayref messages in add_error
+ Add initial fieldset wrapper
+ Flag (localize_labels) in Select field for rendering; localize empty_select
+ Add posted flag for forms containing only fields with no params when unselected
+ Add 'update_fields' methods and 'update_field_list' for preference-type field updates
+ Fix incorrect error message in duration field
+ Use LANGUAGE_HANDLE instead of LANG in tests
+ Add 'input_class' for class attribute on input fields
+ Allow deflation in fif, flag 'deflate_to' => 'value'/'fif'
+ Fix bug with unselected Select field (move input_without_param & not_nullable into field)
+ Add resultset example to cookbook
+ Doc to look at input for multiple submit fields
+ Fix bug in _set_dependency; use 'has_some_value' to determine emptiness
+ Add form_errors for non-field errors
+ Remove deprecated 'min_length' attribute ('minlength' is supported)
+ Allow upload field to be passed a file handle
+ Pass values to Display field (for display-only db fields)
+ Change I18N to allow duck_type classes; add test for Data::Localize
+ Added 'peek' diagnostic function for viewing field & result trees
+ Fix bug with extra results in repeatable elements
+ Strip empty pks and empty elements from repeatable values (avoid DB errors)
+ Localize value of submit button
+ Make '+' unnecessary in front of field name space types
+
0.31003 Fri May 7, 2010
Change precedence of defaults over item/init_object; add 'default_over_obj' for
cases where that behavior is desired.
diff --git a/MANIFEST b/MANIFEST
index 4fcc229..ec65882 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -108,6 +108,7 @@ lib/HTML/FormHandler/Widget/Field/Upload.pm
lib/HTML/FormHandler/Widget/Form/Simple.pm
lib/HTML/FormHandler/Widget/Form/Table.pm
lib/HTML/FormHandler/Widget/Wrapper/Base.pm
+lib/HTML/FormHandler/Widget/Wrapper/Fieldset.pm
lib/HTML/FormHandler/Widget/Wrapper/None.pm
lib/HTML/FormHandler/Widget/Wrapper/Simple.pm
lib/HTML/FormHandler/Widget/Wrapper/Table.pm
@@ -183,6 +184,7 @@ t/result_compound.t
t/result_errors.t
t/structured.t
t/types.t
+t/update_fields.t
t/validate_coderef.t
t/xt/02pod.t
t/xt/add_field.t
@@ -191,15 +193,20 @@ t/xt/chbox_group.t
t/xt/check_selected_option.t
t/xt/custom_fields.t
t/xt/deprecations.t
+t/xt/display.t
t/xt/email.t
t/xt/field_list.t
+t/xt/form_errors.t
t/xt/init.t
t/xt/load_field.t
t/xt/locale.t
+t/xt/locale_data_localize.t
+t/xt/mb_form.t
t/xt/model_cdbi.t
t/xt/multiple_forms.t
t/xt/order.t
t/xt/params.t
+t/xt/posted.t
t/xt/submit.t
t/xt/upload.t
TODO
diff --git a/META.yml b/META.yml
index b25fb97..205062f 100644
--- a/META.yml
+++ b/META.yml
@@ -24,6 +24,8 @@ no_index:
requires:
Carp: 0
DateTime: 0
+ DateTime::Format::Strptime: 0
+ Email::Valid: 0
File::ShareDir: 0
File::Spec: 0
Locale::Maketext: 1.09
@@ -39,4 +41,4 @@ requires:
resources:
license: http://dev.perl.org/licenses/
repository: http://github.com/gshank/html-formhandler/tree/master
-version: 0.31003
+version: 0.32001
diff --git a/Makefile.PL b/Makefile.PL
index 364e340..d960f97 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -18,6 +18,7 @@ requires 'Carp';
requires 'Moose' => '0.90';
requires 'Locale::Maketext' => '1.09';
requires 'DateTime';
+requires 'DateTime::Format::Strptime';
requires 'MooseX::Getopt' => '0.16';
requires 'MooseX::Types' => '0.20';
requires 'MooseX::Types::Common';
@@ -27,6 +28,7 @@ requires 'File::Spec';
requires 'File::ShareDir';
requires 'Try::Tiny';
requires 'namespace::autoclean' => '0.09';
+requires 'Email::Valid';
# things the tests need
test_requires 'Test::More' => '0.88';
diff --git a/lib/HTML/FormHandler.pm b/lib/HTML/FormHandler.pm
index 2c62d00..c2acfcc 100644
--- a/lib/HTML/FormHandler.pm
+++ b/lib/HTML/FormHandler.pm
@@ -12,11 +12,12 @@ with 'MooseX::Traits';
use Carp;
use Class::MOP;
use HTML::FormHandler::Result;
+use Try::Tiny;
use 5.008;
# always use 5 digits after decimal because of toolchain issues
-our $VERSION = '0.31003';
+our $VERSION = '0.32001';
=head1 NAME
@@ -223,6 +224,10 @@ care whether most parameters are set on new or process or update,
but a 'field_list' argument must be passed in on 'new' since the
fields are built at construction time.
+If you want to update field attributes on the 'process' call, you can
+use an 'update_field_list' hashref attribute, or subclass
+update_fields in your form.
+
=head2 Processing the form
=head3 process
@@ -368,6 +373,28 @@ add fields to the form depending on some other state.
return \@field_list;
}
+=head3 update_field_list
+
+Used to dynamically set particular field attributes on the 'process' (or
+'run') call.
+
+ $form->process( update_field_list => {
+ foo_date => { format => '%m/%e/%Y', date_start => '10-01-01' } },
+ params => $params );
+
+The 'update_field_list' is processed by the 'update_fields' form method,
+which can also be used in a form to do specific field updates:
+
+ sub update_fields {
+ my $self = shift;
+ $self->field('foo')->temp( 'foo_temp' );
+ $self->field('bar')->default( 'foo_value' );
+ }
+
+(Note that you can't set a field's 'value' directly here, since it will
+be overwritten by the validation process. Set the value in a field
+validation method.)
+
=head3 active
If a form has a variable number of fields, fields which are not always to be
@@ -479,6 +506,10 @@ more than one field.
=head2 Accessing errors
+Set an error in a field with C<< $field->add_error('some error string'); >>.
+Set a form error not tied to a specific field with
+C<< $self->add_form_error('another error string'); >>.
+
has_errors - returns true or false
error_fields - returns list of fields with errors
errors - returns array of error messages for the entire form
@@ -625,7 +656,9 @@ has 'result' => (
'input', '_set_input', '_clear_input', 'has_input',
'value', '_set_value', '_clear_value', 'has_value',
'add_result', 'results', 'validated', 'ran_validation',
- 'is_valid'
+ 'is_valid',
+ 'form_errors', 'all_form_errors', 'push_form_errors', 'clear_form_errors',
+ 'has_form_errors', 'num_form_errors',
],
);
@@ -658,6 +691,15 @@ has 'active' => (
# object with which to initialize
has 'init_object' => ( is => 'rw', clearer => 'clear_init_object' );
+has 'update_field_list' => ( is => 'rw',
+ isa => 'HashRef',
+ default => sub {{}},
+ traits => ['Hash'],
+ handles => {
+ clear_update_field_list => 'clear',
+ has_update_field_list => 'count',
+ },
+);
has 'reload_after_update' => ( is => 'rw', isa => 'Bool' );
# flags
has [ 'verbose', 'processed', 'did_init_obj' ] => ( isa => 'Bool', is => 'rw' );
@@ -679,6 +721,7 @@ has 'widget_tags' => (
},
);
has 'action' => ( is => 'rw' );
+has 'posted' => ( is => 'rw', isa => 'Bool', clearer => 'clear_posted' );
has 'params' => (
traits => ['Hash'],
isa => 'HashRef',
@@ -807,7 +850,9 @@ sub error_field_names {
sub errors {
my $self = shift;
my @error_fields = $self->error_fields;
- return map { $_->all_errors } @error_fields;
+ my @errors = $self->all_form_errors;
+ push @errors, map { $_->all_errors } @error_fields;
+ return @errors;
}
sub uuid {
@@ -835,8 +880,14 @@ sub validate_form {
sub validate { 1 }
-sub has_errors { shift->has_error_fields }
-sub num_errors { shift->num_error_fields }
+sub has_errors {
+ my $self = shift;
+ return $self->has_error_fields || $self->has_form_errors;
+}
+sub num_errors {
+ my $self = shift;
+ return $self->num_error_fields + $self->num_form_errors;
+}
sub after_update_model {
my $self = shift;
@@ -857,11 +908,16 @@ sub setup_form {
$self->$key($value);
}
}
+ if( $self->posted ) {
+ $self->set_param('__posted' => 1);
+ $self->clear_posted;
+ }
if ( $self->item_id && !$self->item ) {
$self->item( $self->build_item );
}
$self->clear_result;
$self->set_active;
+ $self->update_fields;
# initialization of Repeatable fields and Select options
# will be done in _result_from_object when there's an initial object
# in _result_from_input when there are params
@@ -943,13 +999,7 @@ sub _set_dependency {
# This is to allow requiring a field when a boolean is true.
my $field = $self->field($name);
next if $self->field($name)->type eq 'Boolean' && $value == 0;
- if ( ref $value ) {
- # at least one value is non-blank
- next unless grep { /\S/ } @$value;
- }
- else {
- next unless $value =~ /\S/;
- }
+ next unless has_some_value($value);
# one field was found non-blank, so set all to required
for (@$group) {
my $field = $self->field($_);
@@ -969,6 +1019,16 @@ sub _clear_dependency {
$self->clear_required;
}
+sub peek {
+ my $self = shift;
+ my $string = "Form " . $self->name . "\n";
+ my $indent = ' ';
+ foreach my $field ( $self->sorted_fields ) {
+ $string .= $field->peek( $indent );
+ }
+ return $string;
+}
+
sub _munge_params {
my ( $self, $params, $attr ) = @_;
my $_fix_params = $self->params_class->new( @{ $self->params_args || [] } );
@@ -987,6 +1047,23 @@ after 'get_error_fields' => sub {
}
};
+sub add_form_error {
+ my ( $self, @message ) = @_;
+
+ unless ( defined $message[0] ) {
+ @message = ('form is invalid');
+ }
+ my $out;
+ try {
+ $out = $self->_localize(@message);
+ }
+ catch {
+ die "Error occurred localizing error message for " . $self->name . ". $_";
+ };
+ $self->push_form_errors($out);
+ return;
+}
+
sub apply_field_traits {
my $self = shift;
my $fmeta = HTML::FormHandler::Field->meta;
@@ -998,6 +1075,24 @@ sub apply_field_traits {
sub get_default_value { }
sub _can_deflate { }
+sub update_fields {
+ my $self = shift;
+ return unless $self->has_update_field_list;
+ my $fields = $self->update_field_list;
+ foreach my $key ( keys %$fields ) {
+ my $field = $self->field($key);
+ unless( $field ) {
+ die "Field $key is not found and cannot be updated by update_fields";
+ }
+ while ( my ( $attr_name, $attr_value ) = each %{$fields->{$key}} ) {
+ confess "invalid attribute '$attr_name' passed to update_field_list"
+ unless $field->can($attr_name);
+ $field->$attr_name($attr_value);
+ }
+ }
+ $self->clear_update_field_list;
+}
+
=head1 SUPPORT
IRC:
diff --git a/lib/HTML/FormHandler/BuildFields.pm b/lib/HTML/FormHandler/BuildFields.pm
index 7d3c15d..8fcf87c 100644
--- a/lib/HTML/FormHandler/BuildFields.pm
+++ b/lib/HTML/FormHandler/BuildFields.pm
@@ -72,8 +72,6 @@ sub _build_fields {
}
}
-# process all the stupidly many different formats for field_list
-# remove undocumented syntaxes after a while
sub _process_field_list {
my ( $self, $flist ) = @_;
@@ -114,38 +112,6 @@ sub _build_meta_field_list {
return \@field_list if scalar @field_list;
}
-# munges the field_list auto fields into an array of field attributes
-sub _auto_fields {
- my ( $self, $fields, $required ) = @_;
-
- my @new_fields;
- foreach my $name (@$fields) {
- push @new_fields,
- {
- name => $name,
- type => $self->guess_field_type($name),
- required => $required
- };
- }
- return \@new_fields;
-}
-
-# munges the field_list hashref fields into an array of field attributes
-sub _hashref_fields {
- my ( $self, $fields, $required ) = @_;
- my @new_fields;
- while ( my ( $key, $value ) = each %{$fields} ) {
- unless ( ref $value eq 'HASH' ) {
- $value = { type => $value };
- }
- if ( defined $required ) {
- $value->{required} = $required;
- }
- push @new_fields, { name => $key, %$value };
- }
- return \@new_fields;
-}
-
# munges the field_list array into an array of field attributes
sub _array_fields {
my ( $self, $fields ) = @_;
diff --git a/lib/HTML/FormHandler/Field.pm b/lib/HTML/FormHandler/Field.pm
index b8a2c98..0d27ad2 100644
--- a/lib/HTML/FormHandler/Field.pm
+++ b/lib/HTML/FormHandler/Field.pm
@@ -163,7 +163,9 @@ hash. Validation and constraints act on 'value'.
=item fif
Values used to fill in the form. Read only. Use a deflation to get
-from 'value' to 'fif' if the an inflator was used.
+from 'value' to 'fif' if an inflator was used. (Deflations can be
+done in two different places. Set 'deflate_to' => 'fif' to deflate
+in fillinform'.)
[% form.field('title').fif %]
@@ -225,7 +227,9 @@ Compound fields will have an array of errors from the subfields.
title - Place to put title for field.
style - Place to put field style string
css_class - For a css class name (string; could be several classes,
- separated by spaces or commas)
+ separated by spaces or commas). Used in wrapper for input field.
+ input_class - class attribute on the 'input' field. applied with
+ '_apply_html_attribute' along with disabled/readonly/javascript
id - Useful for javascript (default is html_name. to prefix with
form name, use 'html_prefix' in your form)
disabled - for the HTML flag
@@ -311,6 +315,32 @@ declaration:
has_field 'bax' => ( default => 'Default bax' );
+FormHandler has flipped back and forth a couple of times about whether a default
+specified in the has_field definition should override values provided in an
+initial item or init_object. Sometimes people want one behavior, and sometimes
+the other. Now 'default' does *not* override.
+
+If you pass in a model object with C<< item => $row >> or an initial object
+with C<< init_object => {....} >> the values in that object will be used instead
+of values provided in the field definition with 'default' or 'default_fieldname'.
+
+If you *want* values that override the item/init_object, you can use the field
+attribute 'default_over_obj'.
+
+However you might want to consider putting your defaults into your row or init_object
+instead.
+
+=item default_over_obj
+
+Allows setting defaults which will override values provided with an item/init_object.
+
+ has_field 'quux' => ( default_over_obj => 'default quux' );
+
+At this time there is no equivalent of 'set_default', but the type of the attribute
+is not defined so you can provide default values in a variety of other ways,
+including providing a trait which does 'build_default_over_obj'. For examples,
+see tests in the distribution.
+
=back
=head1 Constraints and Validations
@@ -530,10 +560,15 @@ string and thus needs access to 'self', you would need to use the deflate method
since the deflation coderef is only passed the current value of the field
Normally if you have a deflation, you will need a matching inflation, which can be
-supplied via a 'transform' action. When deflating/inflating values, the 'value' hash
-only contains reliably inflated values after validation has been performed, since
+supplied via a 'transform' action. When using a 'transform', the 'value' hash only
+contains reliably inflated values after validation has been performed, since
inflation is performed at validation time.
+Deflation can be done at two different places: transforming the value that's saved
+from the initial_object/item, or when retrieving the 'fif' (fill-in-form) value that's
+displayed in the HTML form. The default is C<< deflate_to => 'value' >>. To deflate
+when getting the 'fif' value set 'deflate_to' to 'fif'. (See t/deflate.t for examples.)
+
=head1 Processing and validating the field
=head2 validate_field
@@ -566,7 +601,7 @@ has 'input_without_param' => (
is => 'rw',
predicate => 'has_input_without_param'
);
-has 'not_nullable' => ( is => 'ro', isa => 'Bool' );
+has 'not_nullable' => ( is => 'rw', isa => 'Bool' );
has 'init_value' => ( is => 'rw', clearer => 'clear_init_value' );
has 'default' => ( is => 'rw' );
has 'default_over_obj' => ( is => 'rw', builder => 'build_default_over_obj' );
@@ -674,7 +709,12 @@ sub fif {
return defined $lresult->input ? $lresult->input : '';
}
if ( defined $lresult->value ) {
- return $lresult->value;
+ if( $self->deflate_to eq 'fif' && $self->_can_deflate ) {
+ return $self->_apply_deflation($lresult->value);
+ }
+ else {
+ return $lresult->value;
+ }
}
elsif ( defined $self->value ) {
# this is because checkboxes and submit buttons have their own 'value'
@@ -723,6 +763,7 @@ sub loc_label {
has 'title' => ( isa => 'Str', is => 'rw' );
has 'style' => ( isa => 'Str', is => 'rw' );
has 'css_class' => ( isa => 'Str', is => 'rw' );
+has 'input_class' => ( isa => 'Str', is => 'rw' );
has 'form' => (
isa => 'HTML::FormHandler',
is => 'rw',
@@ -838,6 +879,8 @@ has 'deflation' => (
is => 'rw',
predicate => 'has_deflation',
);
+# deflate_to either 'value' or 'fif'
+has 'deflate_to' => ( is => 'rw', default => 'value' );
has 'trim' => (
is => 'rw',
default => sub { { transform => \&default_trim } }
@@ -918,7 +961,7 @@ sub _result_from_fields {
my ( $self, $result ) = @_;
if ( my @values = $self->get_default_value ) {
- if ( $self->_can_deflate ) {
+ if ( $self->_can_deflate && $self->deflate_to eq 'value' ) {
@values = $self->_apply_deflation(@values);
}
my $value = @values > 1 ? \@values : shift @values;
@@ -983,6 +1026,7 @@ sub add_error {
unless ( defined $message[0] ) {
@message = ('field is invalid');
}
+ @message = @{$message[0]} if ref $message[0] eq 'ARRAY';
my $out;
try {
$out = $self->_localize(@message);
@@ -1033,26 +1077,6 @@ sub value_changed {
sub required_text { shift->required ? 'required' : 'optional' }
-sub has_some_value {
- my $x = shift;
-
- return unless defined $x;
- return $x =~ /\S/ if !ref $x;
- if ( ref $x eq 'ARRAY' ) {
- for my $elem (@$x) {
- return 1 if has_some_value($elem);
- }
- return 0;
- }
- if ( ref $x eq 'HASH' ) {
- for my $key ( keys %$x ) {
- return 1 if has_some_value( $x->{$key} );
- }
- return 0;
- }
- return blessed($x); # true if blessed, otherwise false
-}
-
sub input_defined {
my ($self) = @_;
return unless $self->has_input;
@@ -1099,6 +1123,28 @@ sub apply_rendering_widgets {
}
+sub peek {
+ my ( $self, $indent ) = @_;
+
+ $indent ||= '';
+ my $string = $indent . 'field: "' . $self->name . '" type: ' . $self->type . "\n";
+ if( $self->has_flag('has_contains') ) {
+ $string .= $indent . "contains: \n";
+ my $lindent = $indent . ' ';
+ foreach my $field ( $self->contains->sorted_fields ) {
+ $string .= $field->peek( $lindent );
+ }
+ }
+ if( $self->has_fields ) {
+ $string .= $indent . 'subfields of "' . $self->name . '": ' . $self->num_fields . "\n";
+ my $lindent = $indent . ' ';
+ foreach my $field ( $self->sorted_fields ) {
+ $string .= $field->peek( $lindent );
+ }
+ }
+ return $string;
+}
+
=head1 AUTHORS
HTML::FormHandler Contributors; see HTML::FormHandler
diff --git a/lib/HTML/FormHandler/Field/Boolean.pm b/lib/HTML/FormHandler/Field/Boolean.pm
index a8878f1..c84203f 100644
--- a/lib/HTML/FormHandler/Field/Boolean.pm
+++ b/lib/HTML/FormHandler/Field/Boolean.pm
@@ -18,7 +18,7 @@ Similar to Checkbox, except only returns values of 1 or 0.
sub value {
my $self = shift;
- my $v = $self->SUPER::value(@_);
+ my $v = $self->next::method(@_);
return $v ? 1 : 0;
}
diff --git a/lib/HTML/FormHandler/Field/Checkbox.pm b/lib/HTML/FormHandler/Field/Checkbox.pm
index c183029..2159848 100644
--- a/lib/HTML/FormHandler/Field/Checkbox.pm
+++ b/lib/HTML/FormHandler/Field/Checkbox.pm
@@ -45,14 +45,15 @@ has '+input_without_param' => ( default => 0 );
sub value {
my $field = shift;
- return $field->SUPER::value(@_) if @_;
- my $v = $field->SUPER::value;
+ return $field->next::method(@_) if @_;
+ my $v = $field->next::method();
return defined $v ? $v : 0;
}
sub validate {
my $self = shift;
- $self->add_error( $self->required_message ) if ( $self->required && !$self->value );
+ $self->add_error($self->required_message) if( $self->required && !$self->value );
+ return;
}
=head1 AUTHORS
diff --git a/lib/HTML/FormHandler/Field/Display.pm b/lib/HTML/FormHandler/Field/Display.pm
index d459305..dd005a2 100644
--- a/lib/HTML/FormHandler/Field/Display.pm
+++ b/lib/HTML/FormHandler/Field/Display.pm
@@ -19,6 +19,7 @@ or the field's 'html' attribute.
or in a form:
+ has_field 'explanation' => ( type => 'Display' );
sub html_explanation {
my ( $self, $field ) = @_;
if( $self->something ) {
@@ -28,6 +29,13 @@ or in a form:
return '<p>Another type of explanation...</p>';
}
}
+ #----
+ has_field 'username' => ( type => 'Display' );
+ sub html_username {
+ my ( $self, $field ) = @_;
+ return '<div><b>User: </b>' . $field->value . '</div>';
+ }
+
or set the name of the rendering method:
@@ -36,6 +44,9 @@ or set the name of the rendering method:
....
}
+You can also supply an 'html' method with a trait or a custom field. See examples
+in t/field_traits.t and t/xt/display.t of the distribution.
+
=cut
has 'html' => ( is => 'rw', isa => 'Str', builder => 'build_html' );
@@ -80,5 +91,18 @@ sub render {
return '';
}
+sub _result_from_object {
+ my ( $self, $result, $value ) = @_;
+ $self->_set_result($result);
+ $self->value($value);
+ $result->_set_field_def($self);
+ return $result;
+}
+
+after 'clear_data' => sub {
+ my $self = shift;
+ $self->clear_value;
+};
+
__PACKAGE__->meta->make_immutable;
1;
diff --git a/lib/HTML/FormHandler/Field/Duration.pm b/lib/HTML/FormHandler/Field/Duration.pm
index 4be2953..905f23c 100644
--- a/lib/HTML/FormHandler/Field/Duration.pm
+++ b/lib/HTML/FormHandler/Field/Duration.pm
@@ -32,8 +32,8 @@ sub validate {
my @dur_parms;
foreach my $child ( $self->all_fields ) {
- unless ( $child->value =~ /^\d+$/ ) {
- $self->add_error( "Invalid value for [1_] [2_]", $self->loc_label, $child->loc_label );
+ unless ( $child->has_value && $child->value =~ /^\d+$/ ) {
+ $self->add_error( "Invalid value for [_1]: [_2]", $self->loc_label, $child->loc_label );
next;
}
push @dur_parms, ( $child->accessor => $child->value );
diff --git a/lib/HTML/FormHandler/Field/HtmlArea.pm b/lib/HTML/FormHandler/Field/HtmlArea.pm
index c33fcbe..91dcbeb 100644
--- a/lib/HTML/FormHandler/Field/HtmlArea.pm
+++ b/lib/HTML/FormHandler/Field/HtmlArea.pm
@@ -13,7 +13,7 @@ has '+widget' => ( default => 'textarea' );
sub validate {
my $field = shift;
- return unless $field->SUPER::validate;
+ return unless $field->next::method;
$tidy ||= $field->tidy;
$tidy->clear_messages;
diff --git a/lib/HTML/FormHandler/Field/NoValue.pm b/lib/HTML/FormHandler/Field/NoValue.pm
index 6ec5b3f..10e11ca 100644
--- a/lib/HTML/FormHandler/Field/NoValue.pm
+++ b/lib/HTML/FormHandler/Field/NoValue.pm
@@ -19,6 +19,7 @@ has 'html' => ( is => 'rw', isa => 'Str', default => '' );
has 'value' => (
is => 'rw',
predicate => 'has_value',
+ clearer => 'clear_value',
);
sub _result_from_fields {
@@ -50,7 +51,7 @@ has '+noupdate' => ( default => 1 );
sub validate_field { }
-sub clear_value { }
+#sub clear_value { }
sub render {
my $self = shift;
diff --git a/lib/HTML/FormHandler/Field/Password.pm b/lib/HTML/FormHandler/Field/Password.pm
index 68aaa68..68f15a4 100644
--- a/lib/HTML/FormHandler/Field/Password.pm
+++ b/lib/HTML/FormHandler/Field/Password.pm
@@ -58,7 +58,7 @@ sub validate {
my $self = shift;
$self->noupdate(0);
- return unless $self->SUPER::validate;
+ return unless $self->next::method;
my $value = $self->value;
if ( $self->form && $self->ne_username ) {
diff --git a/lib/HTML/FormHandler/Field/Repeatable.pm b/lib/HTML/FormHandler/Field/Repeatable.pm
index 10dbdac..e2d2c53 100644
--- a/lib/HTML/FormHandler/Field/Repeatable.pm
+++ b/lib/HTML/FormHandler/Field/Repeatable.pm
@@ -32,7 +32,7 @@ database relationship) use the 'contains' pseudo field name:
message => 'Not a valid tag' } ]
);
-or use 'contains' withsingle fields which are compound fields:
+or use 'contains' with single fields which are compound fields:
has_field 'addresses' => ( type => 'Repeatable' );
has_field 'addresses.contains' => ( type => '+MyAddress' );
@@ -151,7 +151,8 @@ sub create_element {
my $instance = Instance->new(
name => 'contains',
parent => $self,
- form => $self->form
+ form => $self->form,
+ type => 'Repeatable::Instance',
);
# copy the fields from this field into the instance
$instance->add_field( $self->all_fields );
@@ -167,36 +168,27 @@ sub create_element {
}
sub clone_element {
- my ( $self, $result, $index ) = @_;
+ my ( $self, $index ) = @_;
my $field = $self->contains->clone( errors => [], error_fields => [] );
$field->name($index);
$field->parent($self);
- $field->_set_result($result);
- $field->result->_set_field_def($field);
if ( $field->has_fields ) {
- $self->clone_fields( $result, $field, [ $field->all_fields ] );
+ $self->clone_fields( $field, [ $field->all_fields ] );
}
return $field;
}
sub clone_fields {
- my ( $self, $parent_result, $parent, $fields ) = @_;
+ my ( $self, $parent, $fields ) = @_;
my @field_array;
$parent->fields( [] );
foreach my $field ( @{$fields} ) {
- my $result = HTML::FormHandler::Field::Result->new(
- name => $field->name,
- parent => $parent_result
- );
my $new_field = $field->clone( errors => [], error_fields => [] );
if ( $new_field->has_fields ) {
- $self->clone_fields( $result, $new_field, [ $new_field->all_fields ] );
+ $self->clone_fields( $new_field, [ $new_field->all_fields ] );
}
$new_field->parent($parent);
- $new_field->_set_result($result);
- $new_field->result->_set_field_def($new_field);
- $parent_result->add_result($result);
$parent->add_field($new_field);
}
}
@@ -215,11 +207,11 @@ sub _result_from_input {
my $index = 0;
foreach my $element ( @{$input} ) {
next unless $element;
+ my $field = $self->clone_element( $index );
my $result = HTML::FormHandler::Field::Result->new(
name => $index,
parent => $self->result
);
- my $field = $self->clone_element( $result, $index );
$result = $field->_result_from_input( $result, $element, 1 );
$self->result->add_result($result);
$self->add_field($field);
@@ -247,9 +239,9 @@ sub _result_from_object {
$values = [$values] if ( $values && ref $values ne 'ARRAY' );
foreach my $element ( @{$values} ) {
next unless $element;
+ my $field = $self->clone_element( $index );
my $result =
HTML::FormHandler::Field::Result->new( name => $index, parent => $self->result );
- my $field = $self->clone_element( $result, $index );
$result = $field->_result_from_object( $result, $element );
push @new_values, $result->value;
$self->add_field($field);
@@ -274,9 +266,9 @@ sub _result_from_fields {
# build empty instance
$self->fields( [] );
while ( $count > 0 ) {
+ my $field = $self->clone_element( $index );
my $result =
HTML::FormHandler::Field::Result->new( name => $index, parent => $self->result );
- my $field = $self->clone_element( $result, $index );
$result = $field->_result_from_fields($result);
$result->add_result( $field->result ) if $result;
$self->add_field($field);
@@ -288,6 +280,27 @@ sub _result_from_fields {
return $result;
}
+before 'value' => sub {
+ my $self = shift;
+ my @pk_elems = map { $_->accessor } grep { $_->has_flag('is_primary_key') } $self->contains->all_fields
+ if $self->contains->has_flag('is_compound');
+ my $value = $self->result->value;
+ my @new_value;
+ foreach my $element ( @{$value} ) {
+ next unless $element;
+ if( ref $element eq 'HASH' ) {
+ foreach my $pk ( @pk_elems ) {
+ delete $element->{$pk}
+ if exists $element->{$pk} && (!defined $element->{$pk} || $element->{$pk} eq '');
+ }
+ next unless keys %$element;
+ next unless grep { defined $_ && $_ ne '' } values %$element;
+ }
+ push @new_value, $element;
+ }
+ $self->_set_value(\@new_value);
+};
+
__PACKAGE__->meta->make_immutable;
use namespace::autoclean;
1;
diff --git a/lib/HTML/FormHandler/Field/Result.pm b/lib/HTML/FormHandler/Field/Result.pm
index 61b417a..01288cf 100644
--- a/lib/HTML/FormHandler/Field/Result.pm
+++ b/lib/HTML/FormHandler/Field/Result.pm
@@ -34,6 +34,23 @@ sub render {
return $self->field_def->render($self);
}
+
+sub peek {
+ my ( $self, $indent ) = @_;
+ $indent ||= '';
+ my $name = $self->field_def ? $self->field_def->full_name : $self->name;
+ my $type = $self->field_def ? $self->field_def->type : 'unknown';
+ my $string = $indent . "result " . $name . " type: " . $type . "\n";
+ if( $self->has_results ) {
+ $indent .= ' ';
+ foreach my $res ( $self->results ) {
+ $string .= $res->peek( $indent );
+ }
+ }
+ return $string;
+}
+
+
=head1 AUTHORS
HTML::FormHandler Contributors; see HTML::FormHandler
diff --git a/lib/HTML/FormHandler/Field/Select.pm b/lib/HTML/FormHandler/Field/Select.pm
index dfe05e2..9dec3d4 100644
--- a/lib/HTML/FormHandler/Field/Select.pm
+++ b/lib/HTML/FormHandler/Field/Select.pm
@@ -15,8 +15,16 @@ This is a field that includes a list of possible valid options.
This can be used for select and multiple-select fields.
Widget type is 'select'.
+Because select lists and checkbox_groups do not return an HTTP
+parameter when the entire list is unselected, the Select field
+must assume that the lack of a param means unselection. So to
+avoid setting a Select field, it must be set to inactive, not
+merely not included in the HTML for a form.
+
This field type can also be used for fields that use the
-'radio_group' widget.
+'radio_group' widget, and the 'checkbox_group' widget (for
+selects with multiple flag turned on, or that use the Multiple
+field).
The 'options' array can come from four different places.
The options attribute itself, either declaratively or using a
@@ -141,6 +149,11 @@ object class for the label for select lists.
Defaults to "name"
+=head2 localize_labels
+
+For the renderers: whether or not to call the localize method on the select
+labels. Default is off.
+
=head2 active_column
Sets or returns the name of a boolean column that is used as a flag to indicate that
@@ -214,6 +227,7 @@ sub BUILD {
my $self = shift;
$self->options_from('build') if $self->options && $self->has_options;
+ $self->input_without_param; # vivify
}
has 'set_options' => ( isa => 'Str', is => 'ro');
@@ -250,11 +264,23 @@ sub _form_options {
has 'multiple' => ( isa => 'Bool', is => 'rw', default => '0' );
has 'size' => ( isa => 'Int|Undef', is => 'rw' );
has 'label_column' => ( isa => 'Str', is => 'rw', default => 'name' );
+has 'localize_labels' => ( isa => 'Bool', is => 'rw' );
has 'active_column' => ( isa => 'Str', is => 'rw', default => 'active' );
has 'auto_widget_size' => ( isa => 'Int', is => 'rw', default => '0' );
has 'sort_column' => ( isa => 'Str', is => 'rw' );
has '+widget' => ( default => 'select' );
has 'empty_select' => ( isa => 'Str', is => 'rw' );
+has '+input_without_param' => ( lazy => 1, builder => 'build_input_without_param' );
+sub build_input_without_param {
+ my $self = shift;
+ if( $self->multiple ) {
+ $self->not_nullable(1);
+ return [];
+ }
+ else {
+ return '';
+ }
+}
sub select_widget {
my $field = shift;
@@ -309,7 +335,7 @@ sub _inner_validate_field {
sub _result_from_object {
my ( $self, $result, $item ) = @_;
- $result = $self->SUPER::_result_from_object( $result, $item );
+ $result = $self->next::method( $result, $item );
$self->_load_options;
return $result;
}
@@ -317,7 +343,7 @@ sub _result_from_object {
sub _result_from_fields {
my ( $self, $result ) = @_;
- $result = $self->SUPER::_result_from_fields($result);
+ $result = $self->next::method($result);
$self->_load_options;
return $result;
}
@@ -325,7 +351,7 @@ sub _result_from_fields {
sub _result_from_input {
my ( $self, $result, $input, $exists ) = @_;
- $result = $self->SUPER::_result_from_input( $result, $input, $exists );
+ $result = $self->next::method( $result, $input, $exists );
$self->_load_options;
return $result;
}
@@ -373,6 +399,14 @@ sub _load_options {
sub sort_options { shift; return shift; }
+before 'value' => sub {
+ my $self = shift;
+ my $value = $self->result->value;
+ if( $self->multiple && (!defined $value || $value eq '') ) {
+ $self->_set_value([]);
+ }
+};
+
=head1 AUTHORS
Gerda Shank, gshank at cpan.org
diff --git a/lib/HTML/FormHandler/Field/Submit.pm b/lib/HTML/FormHandler/Field/Submit.pm
index 1ac4d97..4411f2c 100644
--- a/lib/HTML/FormHandler/Field/Submit.pm
+++ b/lib/HTML/FormHandler/Field/Submit.pm
@@ -18,6 +18,10 @@ a form with C<< $form->render >>.
Uses the 'submit' widget.
+If you have multiple submit buttons, currently the only way to test
+which one has been clicked is with C<< $field->input >>. The 'value'
+attribute is used for the HTML input field 'value'.
+
=cut
has '+value' => ( default => 'Save' );
diff --git a/lib/HTML/FormHandler/Field/Text.pm b/lib/HTML/FormHandler/Field/Text.pm
index 0635198..fbe4140 100644
--- a/lib/HTML/FormHandler/Field/Text.pm
+++ b/lib/HTML/FormHandler/Field/Text.pm
@@ -12,29 +12,13 @@ has 'maxlength_message' => ( isa => 'Str', is => 'rw',
has 'minlength' => ( isa => 'Int|Undef', is => 'rw', default => '0' );
has 'minlength_message' => ( isa => 'Str', is => 'rw',
default => 'Field must be at least [quant,_1,character]. You entered [_2]' );
-has 'min_length' => (
- isa => 'Int|Undef',
- is => 'rw',
- default => '0',
- reader => '_min_length_r',
- writer => '_min_length_w'
-); # for backcompat
-
-sub min_length {
- my ( $self, $value ) = @_;
- warn "Please use the 'minlength' attribute - 'min_length' is deprecated";
- if ($value) {
- $self->_min_length_w($value);
- }
- return $self->_min_length_r;
-}
has '+widget' => ( default => 'text' );
sub validate {
my $field = shift;
- return unless $field->SUPER::validate;
+ return unless $field->next::method;
my $value = $field->input;
# Check for max length
if ( my $maxlength = $field->maxlength ) {
@@ -44,7 +28,7 @@ sub validate {
}
# Check for min length
- if ( my $minlength = $field->minlength || $field->_min_length_r ) {
+ if ( my $minlength = $field->minlength ) {
return $field->add_error(
$field->minlength_message,
$minlength, length $value, $field->loc_label )
diff --git a/lib/HTML/FormHandler/Field/Upload.pm b/lib/HTML/FormHandler/Field/Upload.pm
index fc2bf6b..f678aab 100644
--- a/lib/HTML/FormHandler/Field/Upload.pm
+++ b/lib/HTML/FormHandler/Field/Upload.pm
@@ -13,8 +13,10 @@ HTML::FormHandler::Field::Upload - File upload field
=head1 DESCRIPTION
-This field is designed to be used with L<Catalyst::Request::Upload>.
-Validates that the input is an uploaded file.
+This field is designed to be used with a blessed object with a 'size' method,
+such as L<Catalyst::Request::Upload>, or a filehandle.
+Validates that the file is not empty and is within the 'min_size'
+and 'max_size' limits (limits are in bytes).
A form containing this field must have the enctype set.
package My::Form::Upload;
@@ -23,7 +25,7 @@ A form containing this field must have the enctype set.
has '+enctype' => ( default => 'multipart/form-data');
- has_field 'file' => ( type => 'Upload' );
+ has_field 'file' => ( type => 'Upload', max_size => '2000000' );
has_field 'submit' => ( type => 'Submit', value => 'Upload' );
In your controller:
@@ -51,19 +53,46 @@ sub validate {
my $self = shift;
my $upload = $self->value;
- blessed($upload) and
- $upload->size > 0 or
+ my $size = 0;
+ if( blessed $upload && $upload->can('size') ) {
+ $size = $upload->size;
+ }
+ elsif( is_real_fh( $upload ) ) {
+ $size = -s $upload;
+ }
+ else {
+ return $self->add_error('File not found for upload field');
+ }
+ $size > 0 or
return $self->add_error('File uploaded is empty');
- my $size = $upload->size;
-
- $upload->size >= $self->min_size or
+ $size >= $self->min_size or
return $self->add_error( 'File is too small (< [_1] bytes)', $self->min_size );
- $upload->size <= $self->max_size or
+ $size <= $self->max_size or
return $self->add_error( 'File is too big (> [_1] bytes)', $self->max_size );
}
+# stolen from Plack::Util::is_real_fh
+sub is_real_fh {
+ my $fh = shift;
+
+ my $reftype = Scalar::Util::reftype($fh) or return;
+ if( $reftype eq 'IO'
+ or $reftype eq 'GLOB' && *{$fh}{IO} ){
+ my $m_fileno = $fh->fileno;
+ return unless defined $m_fileno;
+ return unless $m_fileno >= 0;
+ my $f_fileno = fileno($fh);
+ return unless defined $f_fileno;
+ return unless $f_fileno >= 0;
+ return 1;
+ }
+ else {
+ return;
+ }
+}
+
__PACKAGE__->meta->make_immutable;
=head1 AUTHOR
diff --git a/lib/HTML/FormHandler/I18N.pm b/lib/HTML/FormHandler/I18N.pm
index 89ebd10..de77f47 100644
--- a/lib/HTML/FormHandler/I18N.pm
+++ b/lib/HTML/FormHandler/I18N.pm
@@ -6,6 +6,7 @@ use Try::Tiny;
sub maketext {
my ( $lh, @message ) = @_;
+ return unless scalar @message;
my $out;
try {
$out = $lh->SUPER::maketext(@message);
diff --git a/lib/HTML/FormHandler/InitResult.pm b/lib/HTML/FormHandler/InitResult.pm
index f166a96..19e4f0e 100644
--- a/lib/HTML/FormHandler/InitResult.pm
+++ b/lib/HTML/FormHandler/InitResult.pm
@@ -116,7 +116,7 @@ sub _get_value {
else {
return;
}
- if( $field->_can_deflate ) {
+ if( $field->_can_deflate && $field->deflate_to eq 'value' ) {
@values = $field->_apply_deflation(@values);
}
my $value = @values > 1 ? \@values : shift @values;
diff --git a/lib/HTML/FormHandler/Manual/Cookbook.pod b/lib/HTML/FormHandler/Manual/Cookbook.pod
index 1c26fe3..4537981 100644
--- a/lib/HTML/FormHandler/Manual/Cookbook.pod
+++ b/lib/HTML/FormHandler/Manual/Cookbook.pod
@@ -362,7 +362,7 @@ in a form you should use an 'around' method modifier and a transaction:
my $item = $self->item;
$self->schema->txn_do( sub {
- $orig->($self, @_);
+ $self->$orig->(@_);
<perform additional updates>
});
@@ -482,11 +482,193 @@ And here's where the coderef is passed in to the form.
}
1;
+=head2 Example of a form with custom database interface
+
+The default DBIC model requires that the form structure match the database
+structure. If that doesn't work - you need to present the form in a different
+way - you may need to fudge it by creating your own 'init_object' and doing
+the database updates in the 'update_model' method.
+
+Here is a working example for a 'family' object (equivalent to a 'user'
+record') that has a relationship to permission type roles in a relationship
+'user_roles'.
+
+ package My::Form::AdminRoles;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has 'schema' => ( is => 'ro', required => 1 ); # Note 1
+ has '+widget_wrapper' => ( default => 'None' ); # Note 2
+
+ has_field 'admin_roles' => ( type => 'Repeatable' ); # Note 3
+ has_field 'admin_roles.family' => ( type => 'Hidden' ); # Note 4
+ has_field 'admin_roles.family_id' => ( type => 'PrimaryKey' ); # Note 5
+ has_field 'admin_roles.admin_flag' => ( type => 'Boolean', label => 'Admin' );
+
+ # Note 6
+ sub init_object {
+ my $self = shift;
+
+ my @is_admin;
+ my @is_not_admin;
+ my $active_families = $self->schema->resultset('Family')->search( { active => 1 } );
+ while ( my $fam = $active_families->next ) {
+ my $admin_flag =
+ $fam->search_related('user_roles', { role_id => 2 } )->count > 0 ? 1 : 0;
+ my $family_name = $fam->name1 . ", " . $fam->name2;
+ my $elem = { family => $family_name, family_id => $fam->family_id,
+ admin_flag => $admin_flag };
+ if( $admin_flag ) {
+ push @is_admin, $elem;
+ }
+ else {
+ push @is_not_admin, $elem;
+ }
+ }
+ # Note 7
+ # sort into admin flag first, then family_name
+ @is_admin = sort { $a->{family} cmp $b->{family} } @is_admin;
+ @is_not_admin = sort { $a->{family} cmp $b->{family} } @is_not_admin;
+ return { admin_roles => [@is_admin, @is_not_admin] };
+ }
+
+ # Note 8
+ sub update_model {
+ my $self = shift;
+
+ my $families = $self->schema->resultset('Family');
+ my $family_roles = $self->value->{admin_roles};
+ foreach my $elem ( @{$family_roles} ) {
+ my $fam = $families->find( $elem->{family_id} );
+ my $has_admin_flag = $fam->search_related('user_roles', { role_id => 2 } )->count > 0;
+ if( $elem->{admin_flag} == 1 && !$has_admin_flag ) {
+ $fam->create_related('user_roles', { role_id => 2 } );
+ }
+ elsif( $elem->{admin_flag} == 0 && $has_admin_flag ) {
+ $fam->delete_related('user_roles', { role_id => 2 } );
+ }
+ }
+ }
+
+Note 1: This form creates its own 'schema' attribute. You could inherit from
+L<HTML::FormHandler::Model::DBIC>, but you won't be using its update code, so
+it wouldn't add much.
+
+Note 2: The form will be displayed with a template that uses 'bare' form input
+fields, so 'widget_wrapper' is set to 'None' to skip wrapping the form inputs with
+divs or table elements.
+
+Note 3: This form consists of an array of elements, so there will be a single
+Repeatable form field with subfields. If you wanted to use automatic rendering, you would
+also need to create a 'submit' field, but in this case it will just be done
+in the template.
+
+Note 4: This field is actually going to be used for display purposes only, but it's
+a hidden field because otherwise the information would be lost when displaying
+the form from parameters. For this case there is no real 'validation' so it
+might not be necessary, but it would be required if the form needed to be
+re-displayed with error messages.
+
+Note 5: The 'family_id' is the primary key field, necessary for updating the
+correct records.
+
+Note 6: 'init_object' method: This is where the initial object is created, which
+takes the place of a database row for form creation.
+
+Note 7: The entries with the admin flag turned on are sorted into the beginning
+of the list. This is entirely a user interface choice.
+
+Note 8: 'update_model' method: This is where the database updates are performed.
+
+
+The Template Toolkit template for this form:
+
+ <h1>Update admin status for members</h1>
+ <form name="adminroles" method="POST" action="[% c.uri_for('admin_roles') %]">
+ <input class="submit" name="submit" value="Save" type="submit">
+ <table border="1">
+ <th>Family</th><th>Admin</th>
+ [% FOREACH f IN form.field('admin_roles').sorted_fields %]
+ <tr>
+ <td><b>[% f.field('family').fif %]</b>[% f.field('family').render %]
+ [% f.field('family_id').render %]</td><td> [% f.field('admin_flag').render %]</td>
+ </tr>
+ [% END %]
+ </table>
+ <input class="submit" name="submit" value="Save" type="submit">
+ </form
+
+The form is rendered in a simple table, with each field rendered using the
+automatically installed rendering widgets with no wrapper (widget_wrapper => 'None').
+There are two hidden fields here, so what is actually seen is two columns, one with
+the user (family) name, the other with a checkbox showing whether the user has
+admin status. Notice that the 'family' field information is rendered twice: once
+as a hidden field that will allow it to be preserved in params, once as a label.
+
+The Catalyst controller action to execute the form:
+
+ sub admin_roles : Local {
+ my ( $self, $c ) = @_;
+
+ my $schema = $c->model('DB')->schema;
+ my $form = My::Form::AdminRoles->new( schema => $schema );
+ $form->process( params => $c->req->params );
+ # re-process if form validated to reload from db and re-sort
+ $form->process( params => {}) if $form->validated;
+ $c->stash( form => $form, template => 'admin/admin_roles.tt' );
+ return;
+ }
+
+Rather than redirect to some other page after saving the form, the form is redisplayed.
+If the form has been validated (i.e. the 'update_model' method has been run), the
+'process' call is run again in order to re-sort the displayed list with admin users at
+the top. That could have also been done in the 'update_model' method.
+
+=head2 A form that takes a resultset, with custom update_model
+
+For updating a Repeatable field that is filled from a Resultset, and not a
+relationship on a single row. Creates a 'resultset' attribute to pass in
+a resultset. Massages the data into an array that's pointed to by an
+'employers' hash key, and does the reverse in the 'update_model' method.
+Yes, it's a kludge, but it could be worse. If you want to impement a more
+general solution, patches welcome.
+
+ package Test::Resultset;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler::Model::DBIC';
+
+ has '+item_class' => ( default => 'Employer' );
+ has 'resultset' => ( isa => 'DBIx::Class::ResultSet', is => 'rw', trigger => sub { shift->set_resultset(@_) } );
+ sub set_resultset {
+ my ( $self, $resultset ) = @_;
+ $self->schema( $resultset->result_source->schema );
+ }
+ sub init_object {
+ my $self = shift;
+ my $rows = [$self->resultset->all];
+ return { employers => $rows };
+ }
+ has_field 'employers' => ( type => 'Repeatable' );
+ has_field 'employers.employer_id' => ( type => 'PrimaryKey' );
+ has_field 'employers.name';
+ has_field 'employers.category';
+ has_field 'employers.country';
+
+ sub update_model {
+ my $self = shift;
+ my $values = $self->values->{employers};
+ foreach my $row (@$values) {
+ delete $row->{employer_id} unless defined $row->{employer_id};
+ $self->resultset->update_or_create( $row );
+ }
+ }
+
+
=head1 AUTHOR
Gerda Shank, gshank at cpan.org
-=head1 COPYRIGHT
+=head1 LICENSE
This library is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.
diff --git a/lib/HTML/FormHandler/Manual/Intro.pod b/lib/HTML/FormHandler/Manual/Intro.pod
index 85e9f5f..6c493ab 100644
--- a/lib/HTML/FormHandler/Manual/Intro.pod
+++ b/lib/HTML/FormHandler/Manual/Intro.pod
@@ -336,6 +336,20 @@ and set the 'fif' hash in the 'fillinform' stash variable:
$c->stash( fillinform => $self->form->fif );
return unless $form->validated;
+Note that FormHandler by default uses empty params as a signal that the
+form has not actually been posted, and so will not attempt to validate
+a form with empty params. Most of the time this works OK, but if you
+have a small form with only the controls that do not return a post
+parameter if unselected (checkboxes and select lists), then the form
+will not be validated if everything is unselected. For this case you
+can either add a hidden field, or use the 'posted' flag:
+
+ $form->process( posted => ($c->req->method eq 'POST', params => ... );
+
+The corollary is that you will confuse FormHandler if you add extra params.
+It's often a better idea to add Moose attributes to the form rather than
+'dummy' fields if the data is not coming from a form control.
+
=head1 Form generator
A DBIC form generator is installed with the L<HTML::FormHandler::Model::DBIC>
@@ -829,11 +843,14 @@ Override the model's 'update_model' method to do additional updates.
sub update_model {
my $self = shift;
- $self->SUPER::update_model;
+ $self->next::method;
my $event = $self->item;
$event->update( ... );
}
+You may want to use DBIC's 'txn_do' to keep updates in the same transaction.
+See L<HTML::FormHandler::Manual::Cookbook> for an example.
+
=back
=head1 Filling the HTML form with values
@@ -919,7 +936,7 @@ has lots of examples. Here is an example of a test script for a DBIC form:
ok ($book, 'get book object from form');
my $num_genres = $book->genres->count;
is( $num_genres, 2, 'multiple select list updated ok');
- is( $form->value('format'), 2, 'get value for format' );
+ is( $form->field('format')->value, 2, 'get value for format' );
my $bad_1 = {
notitle => 'not req',
diff --git a/lib/HTML/FormHandler/Render/Simple.pm b/lib/HTML/FormHandler/Render/Simple.pm
index 6bc9298..96bb5a7 100644
--- a/lib/HTML/FormHandler/Render/Simple.pm
+++ b/lib/HTML/FormHandler/Render/Simple.pm
@@ -276,7 +276,7 @@ sub render_select {
$output .= '>';
my $index = 0;
if( $field->empty_select ) {
- $output .= '<option value="">' . $field->empty_select . '</option>';
+ $output .= '<option value="">' . $field->_localize($field->empty_select) . '</option>';
}
foreach my $option ( @{ $field->options } ) {
$output .= '<option value="' . $field->html_filter($option->{value}) . '" ';
@@ -300,7 +300,8 @@ sub render_select {
if $option->{value} eq $field->fif;
}
}
- $output .= '>' . $field->html_filter($option->{label}) . '</option>';
+ my $label = $field->localize_labels ? $field->_localize($option->{label}) : $option->{label};
+ $output .= '>' . $field->html_filter($label) . '</option>';
$index++;
}
$output .= '</select>';
@@ -412,6 +413,9 @@ sub _add_html_attributes {
$output .= ( $field->$attr ? qq{ $attr="} . $field->$attr . '"' : '' );
}
$output .= ($field->javascript ? ' ' . $field->javascript : '');
+ if( $field->input_class ) {
+ $output .= ' class="' . $field->input_class . '"';
+ }
return $output;
}
diff --git a/lib/HTML/FormHandler/Result.pm b/lib/HTML/FormHandler/Result.pm
index 33e089a..f816871 100644
--- a/lib/HTML/FormHandler/Result.pm
+++ b/lib/HTML/FormHandler/Result.pm
@@ -56,6 +56,22 @@ has 'form' => (
# handles => ['render' ]
);
+has 'form_errors' => (
+ traits => ['Array'],
+ is => 'rw',
+ isa => 'ArrayRef[Str]',
+ default => sub { [] },
+ handles => {
+ all_form_errors => 'elements',
+ push_form_errors => 'push',
+ num_form_errors => 'count',
+ has_form_errors => 'count',
+ clear_form_errors => 'clear',
+ }
+);
+
+sub validated { !$_[0]->has_error_results && $_[0]->has_input && !$_[0]->has_form_errors }
+
has 'ran_validation' => ( is => 'rw', isa => 'Bool', default => 0 );
sub fif {
@@ -63,6 +79,16 @@ sub fif {
$self->form->fields_fif($self);
}
+sub peek {
+ my $self = shift;
+ my $string = "Form Result " . $self->name . "\n";
+ my $indent = ' ';
+ foreach my $res ( $self->results ) {
+ $string .= $res->peek( $indent );
+ }
+ return $string;
+}
+
=head1 AUTHORS
HTML::FormHandler Contributors; see HTML::FormHandler
diff --git a/lib/HTML/FormHandler/TraitFor/I18N.pm b/lib/HTML/FormHandler/TraitFor/I18N.pm
index d6846c5..718bd88 100644
--- a/lib/HTML/FormHandler/TraitFor/I18N.pm
+++ b/lib/HTML/FormHandler/TraitFor/I18N.pm
@@ -1,12 +1,13 @@
package HTML::FormHandler::TraitFor::I18N;
-use base 'Locale::Maketext';
use HTML::FormHandler::I18N;
use Moose::Role;
+use Moose::Util::TypeConstraints;
=head3 language_handle, _build_language_handle
-Holds a Locale::Maketext language handle
+Holds a Locale::Maketext (or other duck_type class with a 'maketext'
+method) language handle
The builder for this attribute gets the Locale::Maketext language
handle from the environment variable $ENV{LANGUAGE_HANDLE}, or creates
@@ -29,10 +30,14 @@ Passed into new or process:
If you do not set the language_handle, then L<Locale::Maketext> and/or
L<I18N::LangTags> may guess, with unexpected results.
+You can use non-Locale::Maketext language handles, such as L<Data::Localize>.
+There's an example of building a L<Data::Localize> language handle
+in t/xt/locale_data_localize.t in the distribution.
+
=cut
has 'language_handle' => (
- isa => 'Locale::Maketext',
+ isa => duck_type( [ qw(maketext) ] ),
is => 'rw',
lazy_build => 1,
required => 1,
@@ -49,8 +54,11 @@ sub _build_language_handle {
sub _localize {
my ($self, @message) = @_;
- $self->language_handle->maketext(@message);
+ my $message = $self->language_handle->maketext(@message);
+ return $message;
}
+no Moose::Role;
+no Moose::Util::TypeConstraints;
1;
diff --git a/lib/HTML/FormHandler/Validate.pm b/lib/HTML/FormHandler/Validate.pm
index eabe4fa..b9d5713 100644
--- a/lib/HTML/FormHandler/Validate.pm
+++ b/lib/HTML/FormHandler/Validate.pm
@@ -67,15 +67,7 @@ sub validate_field {
$field->clear_errors; # this is only here for testing convenience
# See if anything was submitted
if ( $field->required && ( !$field->has_input || !$field->input_defined ) ) {
- if ($field->required) {
- my $msg = $field->required_message;
- if ( ref $msg eq 'ARRAY' ) {
- $field->add_error( @$msg );
- }
- else {
- $field->add_error( $msg );
- }
- }
+ $field->add_error( $field->required_message );
if( $field->has_input ) {
$field->not_nullable ? $field->_set_value($field->input) : $field->_set_value(undef);
}
diff --git a/lib/HTML/FormHandler/Validate/Actions.pm b/lib/HTML/FormHandler/Validate/Actions.pm
index 7d613b8..93fe03a 100644
--- a/lib/HTML/FormHandler/Validate/Actions.pm
+++ b/lib/HTML/FormHandler/Validate/Actions.pm
@@ -144,6 +144,30 @@ sub _apply_actions {
}
}
+# this is here because it needs to be in some role that is included
+# in both HFH and HFH::Field. If a better place shows up, move it.
+sub has_some_value {
+ my $x = shift;
+
+ return unless defined $x;
+ return $x =~ /\S/ if !ref $x;
+ if ( ref $x eq 'ARRAY' ) {
+ for my $elem (@$x) {
+ return 1 if has_some_value($elem);
+ }
+ return 0;
+ }
+ if ( ref $x eq 'HASH' ) {
+ for my $key ( keys %$x ) {
+ return 1 if has_some_value( $x->{$key} );
+ }
+ return 0;
+ }
+ return 1 if blessed($x); # true if blessed, otherwise false
+ return 1 if ref( $x );
+ return;
+}
+
=head1 AUTHORS
HTML::FormHandler Contributors; see HTML::FormHandler
diff --git a/lib/HTML/FormHandler/Widget/Field/CheckboxGroup.pm b/lib/HTML/FormHandler/Widget/Field/CheckboxGroup.pm
index b7aca47..f92440e 100644
--- a/lib/HTML/FormHandler/Widget/Field/CheckboxGroup.pm
+++ b/lib/HTML/FormHandler/Widget/Field/CheckboxGroup.pm
@@ -6,9 +6,6 @@ use namespace::autoclean;
with 'HTML::FormHandler::Widget::Field::Role::SelectedOption';
with 'HTML::FormHandler::Widget::Field::Role::HTMLAttributes';
-has 'input_without_param' => ( is => 'ro', default => sub {[]} );
-has 'not_nullable' => ( is => 'ro', default => 1 );
-
sub render {
my $self = shift;
my $result = shift || $self->result;
diff --git a/lib/HTML/FormHandler/Widget/Field/Role/HTMLAttributes.pm b/lib/HTML/FormHandler/Widget/Field/Role/HTMLAttributes.pm
index 08ff20a..c28e9c6 100644
--- a/lib/HTML/FormHandler/Widget/Field/Role/HTMLAttributes.pm
+++ b/lib/HTML/FormHandler/Widget/Field/Role/HTMLAttributes.pm
@@ -10,6 +10,9 @@ sub _add_html_attributes {
$output .= ( $self->$attr ? qq{ $attr="} . $self->$attr . '"' : '' );
}
$output .= ($self->javascript ? ' ' . $self->javascript : '');
+ if( $self->input_class ) {
+ $output .= ' class="' . $self->input_class . '"';
+ }
return $output;
}
diff --git a/lib/HTML/FormHandler/Widget/Field/Select.pm b/lib/HTML/FormHandler/Widget/Field/Select.pm
index c3c5f2c..d3e4de4 100644
--- a/lib/HTML/FormHandler/Widget/Field/Select.pm
+++ b/lib/HTML/FormHandler/Widget/Field/Select.pm
@@ -20,8 +20,10 @@ sub render {
$output .= $self->_add_html_attributes;
$output .= '>';
- $t = $self->empty_select
- and $output .= qq{<option value="">$t</option>};
+ if( $self->empty_select ) {
+ $t = $self->_localize($self->empty_select);
+ $output .= qq{<option value="">$t</option>};
+ }
foreach my $option ( @{ $self->{options} } ) {
$output .= '<option value="'
@@ -48,7 +50,8 @@ sub render {
}
$output .= ' selected="selected"'
if $self->check_selected_option($option);
- $output .= '>' . $self->html_filter($option->{label}) . '</option>';
+ my $label = $self->localize_labels ? $self->_localize($option->{label}) : $option->{label};
+ $output .= '>' . $self->html_filter($label) . '</option>';
$index++;
}
$output .= '</select>';
diff --git a/lib/HTML/FormHandler/Widget/Wrapper/Fieldset.pm b/lib/HTML/FormHandler/Widget/Wrapper/Fieldset.pm
new file mode 100644
index 0000000..5e490ec
--- /dev/null
+++ b/lib/HTML/FormHandler/Widget/Wrapper/Fieldset.pm
@@ -0,0 +1,33 @@
+package HTML::FormHandler::Widget::Wrapper::Fieldset;
+
+use Moose::Role;
+use namespace::autoclean;
+
+with 'HTML::FormHandler::Widget::Wrapper::Base';
+
+=head1 NAME
+
+HTML::FormHandler::Widget::Wrapper::Fieldset
+
+=head1 SYNOPSIS
+
+Wraps a single field in a fieldset.
+
+=cut
+
+sub wrap_field {
+ my ( $self, $result, $rendered_widget ) = @_;
+
+ my $output .= '<fieldset class="' . $self->html_name . '">';
+ $output .= '<legend>' . $self->loc_label . '</legend>';
+
+ $output .= $rendered_widget;
+
+ $output .= qq{\n<span class="error_message">$_</span>}
+ for $result->all_errors;
+ $output .= '</fieldset>';
+
+ return "$output\n";
+}
+
+1;
diff --git a/t/compound_field.t b/t/compound_field.t
index b3f45ce..e59f782 100644
--- a/t/compound_field.t
+++ b/t/compound_field.t
@@ -3,6 +3,8 @@ use Test::More;
use lib 't/lib';
use_ok( 'HTML::FormHandler::Field::Duration');
+use HTML::FormHandler::I18N;
+$ENV{LANGUAGE_HANDLE} = HTML::FormHandler::I18N->get_handle('en_en');
my $field = HTML::FormHandler::Field::Duration->new( name => 'duration' );
@@ -43,6 +45,10 @@ ok( $form->validated, 'form validated' );
is_deeply($form->fif, $params, 'get fif with right value');
is( $form->field('duration')->value->hours, 2, 'duration value is correct');
+$form->process( params => { name => 'Testing', 'duration.hours' => 'abc', 'duration.inutes' => 'xyz' } );
+ok( $form->has_errors, 'form does not validate' );
+my @errors = $form->errors;
+is( $errors[0], 'Invalid value for Duration: Hours', 'correct error message' );
{
package Form::Start;
diff --git a/t/dates.t b/t/dates.t
index 77f7e03..ac13bc6 100644
--- a/t/dates.t
+++ b/t/dates.t
@@ -3,12 +3,8 @@ use warnings;
use Test::More;
-BEGIN {
- eval "use DateTime::Format::Strptime";
- plan skip_all => 'DateTime::Format::Strptime required' if $@;
-}
-
-$ENV{LANG} = 'en_us'; # in case user has LANG set
+use HTML::FormHandler::I18N;
+$ENV{LANGUAGE_HANDLE} = HTML::FormHandler::I18N->get_handle('en_en');
#
# DateMDY
diff --git a/t/defaults.t b/t/defaults.t
index 740b29b..34ede90 100644
--- a/t/defaults.t
+++ b/t/defaults.t
@@ -1,6 +1,44 @@
+use strict;
+use warnings;
use Test::More;
use lib 't/lib';
+{
+ package Test::Defaults;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has_field 'foo' => ( default => 'default_foo' );
+ has_field 'bar' => ( default => '' );
+ has_field 'bax' => ( default => 'default_bax' );
+}
+
+my $form = Test::Defaults->new;
+my $cmp_fif = {
+ foo => 'default_foo',
+ bar => '',
+ bax => 'default_bax',
+};
+is_deeply( $form->fif, $cmp_fif, 'fif has right defaults' );
+$form->process( params => {} );
+is_deeply( $form->fif, $cmp_fif, 'fif has right defaults' );
+
+my $init_obj = { foo => '', bar => 'testing', bax => '' };
+$form->process( init_object => $init_obj, params => {} );
+is_deeply( $form->fif, { foo => '', bar => 'testing', bax => '' }, 'object overrides defaults');
+
+{
+ package Test::DefaultsX;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has_field 'foo' => ( default => 'default_foo', default_over_obj => 'default_foo' );
+ has_field 'bar' => ( default => '', default_over_obj => '' );
+ has_field 'bax' => ( default => 'default_bax', default_over_obj => 'default_bax' );
+}
+$form = Test::DefaultsX->new;
+$form->process( init_object => $init_obj, params => {} );
+is_deeply( $form->fif, $cmp_fif, 'fif uses defaults overriding object' );
{
package My::Form;
@@ -14,7 +52,7 @@ use lib 't/lib';
}
-my $form = My::Form->new( init_object => {reqname => 'Starting Perl',
+$form = My::Form->new( init_object => {reqname => 'Starting Perl',
optname => 'Over Again' } );
ok( $form, 'non-db form created OK');
is( $form->field('optname')->value, 'Over Again', 'get right value from form');
@@ -56,6 +94,12 @@ ok( $form->field('bax')->value, 'default_bax' );
use HTML::FormHandler::Moose;
extends 'HTML::FormHandler';
with 'HTML::FormHandler::Model::Object';
+
+ sub BUILD {
+ my $self = shift;
+$DB::single=1;
+ my $var = 'test';
+ }
has_field 'foo';
has_field 'bar';
has_field 'baz';
@@ -69,7 +113,9 @@ ok( $form->field('bax')->value, 'default_bax' );
);
sub init_object {
- { bar => 'initbar' }
+ my $self = shift;
+$DB::single=1;
+ return { bar => 'initbar' };
}
}
diff --git a/t/deflate.t b/t/deflate.t
index 59800fc..e484c90 100644
--- a/t/deflate.t
+++ b/t/deflate.t
@@ -42,9 +42,14 @@ my $init_object = { foo => 'one-1-two-2-three-3', bar => 'xxyyzz' };
$form->process( init_object => $init_object, params => {} );
is_deeply( $form->value, { foo => { one => 1, two => 2, three => 3 },
bar => 'xxyyzz' }, 'value is correct?' );
-$form->process( params => { bar => 'aabbcc', 'foo.one' => 'x', 'foo.two' => 'xx', 'foo.three' => 'xxx' } );
+is_deeply( $form->fif, { 'foo.one' => 1, 'foo.two' => 2, 'foo.three' => 3, bar => 'xxyyzz' },
+ 'fif is correct' );
+
+my $fif = { bar => 'aabbcc', 'foo.one' => 'x', 'foo.two' => 'xx', 'foo.three' => 'xxx' };
+$form->process( params => $fif );
ok( $form->validated, 'form validated' );
is_deeply( $form->value, { bar => 'aabbcc', foo => 'one-x-two-xx-three-xxx' }, 'right value' );
+is_deeply( $form->fif, $fif, 'right fif' );
is( $form->field('foo.one')->fif, 'x', 'correct fif' );
is( $form->field('foo')->value, 'one-x-two-xx-three-xxx', 'right value for foo field' );
@@ -70,8 +75,45 @@ is( $form->field('foo')->value, 'one-x-two-xx-three-xxx', 'right value for foo f
$form = Test::Deflate->new;
ok( $form, 'form builds' );
-
is( $form->field('foo')->value, 'deflated value', 'default values should be deflated too' );
+{
+ package Test::Deflate2;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has_field 'bullets' => ( type => 'Text',
+ apply => [ { transform => \&string_to_array } ],
+ deflation => \&array_to_string,
+ deflate_to => 'fif',
+ );
+ sub array_to_string {
+ my ( $value ) = @_;
+ my $string = '';
+ my $sep = '';
+ for ( @$value ) {
+ $string .= $sep . $_->{text};
+ $sep = ';';
+ }
+ return $string;
+ }
+ sub string_to_array {
+ my $value = shift;
+ return [ map { { text => $_ } } split(/\s*;\s*/, $value) ];
+ }
+}
+
+$init_object = { bullets => [{ text => 'one'}, { text => 'two' }, { text => 'three'}] };
+$fif = { bullets => 'one;two;three' };
+$form = Test::Deflate2->new;
+ok( $form, 'form built');
+$form->process( init_object => $init_object, params => {} );
+is_deeply( $form->fif, $fif, 'right fif' );
+is_deeply( $form->value, $init_object, 'right value' );
+
+$form->process( params => $fif );
+is_deeply( $form->fif, $fif, 'right fif' );
+is_deeply( $form->value, $init_object, 'right value' );
+
done_testing;
diff --git a/t/dependency.t b/t/dependency.t
index 1657008..0ef0082 100644
--- a/t/dependency.t
+++ b/t/dependency.t
@@ -49,4 +49,36 @@ foreach my $field (@error_fields)
is( $field->errors->[0], $field->label . ' field is required', "required field: $name");
}
+{
+ package Test::Form;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has_field 'foo';
+ has_field 'bar';
+ has_field 'baz';
+
+ has '+dependency' => ( default => sub {
+ [
+ [ 'foo', 'bar' ],
+ ]
+ }
+ );
+
+}
+
+{
+ package Test::Obj;
+ use Moose;
+ has 'fox' => ( is => 'ro' );
+ has 'dog' => ( is => 'ro' );
+}
+
+$form = Test::Form->new;
+my $obj = Test::Obj->new( fox => 'test' );
+$form->process( params => { foo => $obj } );
+ok( !$form->validated, 'form did not validate' );
+my @errors = $form->errors;
+is( $errors[0], 'Bar field is required', 'dependency error is correct');
+
done_testing;
diff --git a/t/fields.t b/t/fields.t
index 0b18673..8802286 100644
--- a/t/fields.t
+++ b/t/fields.t
@@ -3,7 +3,8 @@ use warnings;
use Test::More;
-$ENV{LANG} = 'en_us'; # in case user has set LANG to de_de
+use HTML::FormHandler::I18N;
+$ENV{LANGUAGE_HANDLE} = HTML::FormHandler::I18N->get_handle('en_en');
#
# Boolean
diff --git a/t/filters.t b/t/filters.t
index 605bbed..125f836 100644
--- a/t/filters.t
+++ b/t/filters.t
@@ -7,7 +7,8 @@ use lib 't/lib';
use DateTime;
use Scalar::Util qw(blessed);
-$ENV{LANG} = 'en_us'; # in case user has LANG set
+use HTML::FormHandler::I18N;
+$ENV{LANGUAGE_HANDLE} = HTML::FormHandler::I18N->get_handle('en_en');
{
package My::Form;
diff --git a/t/form_handler.t b/t/form_handler.t
index a425bd7..2384d2f 100644
--- a/t/form_handler.t
+++ b/t/form_handler.t
@@ -115,6 +115,7 @@ $fif{must_select} = 1;
ok( $form->process($init_object), 'form validates with params' );
#my %init_obj_value = (%$init_object, fruit => undef );
#is_deeply( $form->value, \%init_obj_value, 'value init obj' );
+$init_object->{fruit} = undef;
is_deeply( $form->value, $init_object, 'value init obj' );
is_deeply( $form->fif, \%fif, 'get right fif with init_object' );
diff --git a/t/form_options.t b/t/form_options.t
index c0cb019..3dff195 100644
--- a/t/form_options.t
+++ b/t/form_options.t
@@ -88,7 +88,6 @@ is_deeply( $field_options, $build_attr_options,
my $params = {
fruit => 2,
vegetables => [2,4],
- empty => '',
};
is( $form->field('fruit')->value, 2, 'initial value ok');
@@ -111,9 +110,9 @@ ok( $form->validated, 'form validated' );
is( $form->field('fruit')->value, 2, 'fruit value is correct');
is_deeply( $form->field('vegetables')->value, [2,4], 'vegetables value is correct');
-is_deeply( $form->fif, { fruit => 2, vegetables => [2, 4], test_field => '', empty => '', build_attr => '' },
+is_deeply( $form->fif, { fruit => 2, vegetables => [2, 4], test_field => '', build_attr => '' },
'fif is correct');
-is_deeply( $form->values, { fruit => 2, vegetables => [2, 4], empty => undef },
+is_deeply( $form->values, { fruit => 2, vegetables => [2, 4], empty => [], build_attr => undef },
'values are correct');
$params = {
diff --git a/t/has_many.t b/t/has_many.t
index ebe6d42..db62e60 100644
--- a/t/has_many.t
+++ b/t/has_many.t
@@ -17,9 +17,6 @@ use_ok( 'HTML::FormHandler::Field::Repeatable::Instance' );
has_field 'addresses.country';
has_field 'addresses.sector' => ( type => 'Select' );
- has_field 'apples' => ( type => 'Repeatable' );
- has_field 'apples.id' => ( type => 'Select' );
-
sub options_addresses_sector
{
[ 1 => 'East',
@@ -28,11 +25,6 @@ use_ok( 'HTML::FormHandler::Field::Repeatable::Instance' );
]
}
- sub options_apples_id {
- [ 1 => 'Red',
- 2 => 'Green',
- ]
- }
}
my $form = Repeatable::Form->new;
@@ -68,9 +60,6 @@ my $init_object = {
id => 2,
}
],
- apples => [
- {},
- ]
};
$form = Repeatable::Form->new( init_object => $init_object );
@@ -81,7 +70,6 @@ $init_object->{my_test} = undef;
$init_object->{addresses}->[0]->{sector} = undef;
$init_object->{addresses}->[1]->{sector} = undef;
$init_object->{addresses}->[2]->{sector} = undef;
-$init_object->{apples}->[0]->{id} = undef;
is_deeply( $form->values, $init_object, 'get values back out' );
delete $init_object->{my_test};
is_deeply( $form->field('addresses')->value, $init_object->{addresses}, 'hasmany field value');
@@ -108,9 +96,7 @@ my $fif = {
'addresses.2.id' => '2',
'addresses.2.sector' => '',
'my_test' => '',
- 'apples.0.id' => '',
};
-
is_deeply( $form->fif, $fif, 'get fill in form');
$fif->{'addresses.0.city'} = 'Primary City';
$fif->{'addresses.2.country'} = 'Grand Fenwick';
@@ -122,7 +108,6 @@ $fif->{my_test} = '';
is_deeply( $form->fif, $fif, 'still get right fif');
$init_object->{addresses}->[0]->{city} = 'Primary City';
$init_object->{addresses}->[2]->{country} = 'Grand Fenwick';
-$init_object->{apples} = [ undef ];
is_deeply( $form->values, $init_object, 'still get right values');
$fif = {
@@ -165,7 +150,6 @@ my $values = {
'sector' => undef,
},
],
- apples => []
};
is_deeply( $form->values, $values, 'get right values' );
@@ -182,4 +166,30 @@ $form->clear_init_object;
$form->process( { my_test => 'test' } );
is_deeply( $form->value()->{addresses}, [], 'Addresses deleted' );
+{
+ package Test::User::Repeatable;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has_field 'user_name';
+ has_field 'occupation';
+ has_field 'employers' => ( type => 'Repeatable' );
+ has_field 'employers.employer_id' => ( type => 'PrimaryKey' );
+ has_field 'employers.name';
+ has_field 'employers.address';
+}
+$form = Test::User::Repeatable->new;
+my $unemployed_params = {
+ user_name => "No Employer",
+ occupation => "Unemployed",
+ 'employers.0.employer_id' => '', # empty string
+ 'employers.0.name' => '',
+ 'employers.0.address' => ''
+};
+$form->process( $unemployed_params);
+ok( $form->validated, "User with empty employer validates" );
+is_deeply( $form->value, { employers => [], user_name => 'No Employer', occupation => 'Unemployed' },
+ 'creates right value for empty repeatable' );
+is_deeply( $form->fif, $unemployed_params, 'right fif for empty repeatable' );
+
done_testing;
diff --git a/t/render.t b/t/render.t
index 90055cd..5e89285 100644
--- a/t/render.t
+++ b/t/render.t
@@ -13,6 +13,7 @@ use HTML::FormHandler::Field::Text;
has '+name' => ( default => 'testform' );
has_field 'test_field' => (
+ input_class => 'test123',
size => 20,
label => 'TEST',
id => 'f99',
@@ -104,7 +105,7 @@ is( $form->render_field( $form->field('number') ),
my $output1 = $form->render_field( $form->field('test_field') );
is( $output1,
'
-<div><label class="label" for="f99">TEST: </label><input type="text" name="test_field" id="f99" size="20" value="something" /></div>
+<div><label class="label" for="f99">TEST: </label><input type="text" name="test_field" id="f99" size="20" value="something" class="test123" /></div>
',
'output from text field');
diff --git a/t/render_widgets.t b/t/render_widgets.t
index 4638c1b..0b75c61 100644
--- a/t/render_widgets.t
+++ b/t/render_widgets.t
@@ -18,6 +18,7 @@ use HTML::FormHandler::Field::Text;
size => 20,
label => 'TEST',
id => 'f99',
+ input_class => 'test123',
);
has_field 'number';
has_field 'fruit' => ( type => 'Select' );
@@ -84,6 +85,7 @@ use HTML::FormHandler::Field::Text;
);
has_field 'no_render' => ( widget => 'no_render' );
has_field 'plain' => ( widget_wrapper => 'None' );
+ has_field 'boxed' => ( widget_wrapper => 'Fieldset' );
sub options_fruit {
return (
@@ -136,6 +138,7 @@ my $params = {
opt_in => 'no & never',
plain => 'No divs!!',
comedians => [ 'chaplin', 'laurel & hardy' ],
+ boxed => 'Testing single fieldset',
};
$form->process($params);
@@ -152,7 +155,7 @@ my $output1 = $form->field('test_field')->render;
is(
$output1,
'
-<div><label class="label" for="f99">TEST: </label><input type="text" name="test_field" id="f99" size="20" value="something" /></div>
+<div><label class="label" for="f99">TEST: </label><input type="text" name="test_field" id="f99" size="20" value="something" class="test123" /></div>
',
'output from text field'
);
@@ -269,6 +272,8 @@ is( $form->field('no_render')->render, '', 'no_render' );
is( $form->field('plain')->render, '<input type="text" name="plain" id="plain" value="No divs!!" />', 'renders without wrapper');
+is( $form->field('boxed')->render, '<fieldset class="boxed"><legend>Boxed</legend><input type="text" name="boxed" id="boxed" value="Testing single fieldset" /></fieldset>
+', 'fieldset wrapper renders' );
{
diff --git a/t/result.t b/t/result.t
index e0180b2..26b128f 100644
--- a/t/result.t
+++ b/t/result.t
@@ -115,7 +115,7 @@ my $values = {
'my_selected' => 0,
'optname' => 'Over Again',
'reqname' => 'Starting Perl',
- 'somename' => undef
+ 'somename' => undef,
};
is_deeply( $result->value, $values, 'get right values from form' );
@@ -123,6 +123,7 @@ $init_object->{my_selected} = 0;
$init_object->{must_select} = 1;
$result = $form->run($init_object);
ok( $result->validated, 'form validates with params' );
+$init_object->{fruit} = undef;
is_deeply( $result->value, $init_object, 'get right values from result' );
ok( !$form->has_value, 'Form value cleared' );
diff --git a/t/types.t b/t/types.t
index 46aefe9..9352632 100644
--- a/t/types.t
+++ b/t/types.t
@@ -5,7 +5,8 @@ use Test::Exception;
use HTML::FormHandler::Types (':all');
-$ENV{LANG} = 'en_us'; # in case user has LANG set
+use HTML::FormHandler::I18N;
+$ENV{LANGUAGE_HANDLE} = HTML::FormHandler::I18N->get_handle('en_en');
{
package Test::Form;
@@ -69,17 +70,14 @@ is( $field->errors->[0], 'Not a valid state', 'correct error message for State'
$field->_set_input('NY');
ok( $field->validate_field, 'state field validated');
# Email
-SKIP: {
- eval { require Email::Valid };
- skip "Email::Valid not installed", 3 if $@;
- $field = HTML::FormHandler::Field->new( name => 'Test', apply => [ Email ] );
- $field->_set_input('gail at gmail.com');
- ok( $field->validate_field, 'email field validated' );
- ok( !$field->has_errors, 'email field is valid');
- $field->_set_input('not_an_email');
- $field->validate_field;
- is( $field->errors->[0], 'Email is not valid', 'error from Email' );
-}
+$field = HTML::FormHandler::Field->new( name => 'Test', apply => [ Email ] );
+$field->_set_input('gail at gmail.com');
+ok( $field->validate_field, 'email field validated' );
+ok( !$field->has_errors, 'email field is valid');
+$field->_set_input('not_an_email');
+$field->validate_field;
+is( $field->errors->[0], 'Email is not valid', 'error from Email' );
+
my @test = (
IPAddress => \&IPAddress =>
[qw(0.0.0.0 01.001.0.00 198.168.0.101 255.255.255.255)],
diff --git a/t/update_fields.t b/t/update_fields.t
new file mode 100644
index 0000000..82f636d
--- /dev/null
+++ b/t/update_fields.t
@@ -0,0 +1,42 @@
+use strict;
+use warnings;
+use Test::More;
+
+{
+ package Test::Dates;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has_field 'foo';
+ has_field 'foo_date' => ( type => 'Date' );
+
+}
+
+my $form = Test::Dates->new;
+my $params = { foo => 'testing', foo_date => '10-06-22' };
+$form->process( update_field_list => { foo_date => { format => '%m/%e/%Y', date_start => '10-01-01' } }, params => $params );
+is( $form->field('foo_date')->date_start, '10-01-01', 'field updated' );
+is( $form->field('foo_date')->format, '%m/%e/%Y', 'field updated' );
+
+{
+ package Test::Field::Updates;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has_field 'foo';
+ has_field 'bar';
+
+ sub update_fields {
+ my $self = shift;
+ $self->field('foo')->temp( 'foo_temp' );
+ $self->field('bar')->default( 'foo_value' );
+ }
+}
+
+$form = Test::Field::Updates->new;
+$form->process;
+is( $form->field('foo')->temp, 'foo_temp', 'foo field updated' );
+is( $form->field('bar')->value, 'foo_value', 'foo value updated from default' );
+
+done_testing;
+
diff --git a/t/xt/display.t b/t/xt/display.t
new file mode 100644
index 0000000..558558c
--- /dev/null
+++ b/t/xt/display.t
@@ -0,0 +1,49 @@
+use strict;
+use warnings;
+use Test::More;
+
+{
+ package Test::Form;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has_field 'foo';
+ has_field 'bar' => ( type => 'Display' );
+ has_field 'baz' => ( type => 'Display' );
+
+ sub html_bar {
+ my ( $self, $field ) = @_;
+ my $html = '<div><b>My Bar:&nbps;</b>' . $field->value . '</div>';
+ return $html;
+ }
+ sub html_baz {
+ my ( $self, $field ) = @_;
+ my $html = '<div><b>My Baz:&nbps;</b>' . $field->value . '</div>';
+ return $html;
+ }
+}
+
+my $form = Test::Form->new;
+
+my $init_obj = {
+ foo => 'we have a foo',
+ bar => '...and a bar...',
+ baz => '...and a baz!!',
+};
+
+$form->process( init_object => $init_obj, params => {} );
+my $rendered = $form->render;
+like( $rendered, qr/and a bar/, 'value for display field renders' );
+like( $rendered, qr/and a baz!!/, 'value for display field renders' );
+
+# testing
+$form->process( init_object => $init_obj, params => { foo => 'new foo' } );
+$rendered = $form->render;
+like( $rendered, qr/and a bar/, 'value for display field still renders' );
+is_deeply( $form->value, { foo => 'new foo' }, 'value for form is correct' );
+is_deeply( $form->fif, { foo => 'new foo' }, 'fif for form is correct' );
+
+
+
+
+done_testing;
diff --git a/t/xt/form_errors.t b/t/xt/form_errors.t
new file mode 100644
index 0000000..1057acf
--- /dev/null
+++ b/t/xt/form_errors.t
@@ -0,0 +1,48 @@
+use strict;
+use warnings;
+use Test::More;
+
+{
+ package Test::Form;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has 'secret' => ( is => 'rw', default => 'wrong' );
+
+ has_field 'foo';
+ has_field 'bar';
+
+ sub validate_foo {
+ my ( $self, $field ) = @_;
+ $field->add_error('Not a valid foo')
+ if( $field->value eq 'test' );
+ }
+ sub validate_bar {
+ my ( $self, $field ) = @_;
+ $field->add_error('Not a valid bar')
+ if( $field->value eq 'bad_bar' );
+ }
+ sub validate {
+ my $self = shift;
+ $self->add_form_error('Try again')
+ if( $self->field('foo')->value ne $self->secret );
+ }
+}
+
+my $form = Test::Form->new;
+ok( $form, 'form builds' );
+$form->process( params => {} );
+my $params = {
+ foo => 'test',
+ bar => 'bad_bar',
+};
+$form->process( secret => 'yikes', params => $params );
+ok( !$form->validated, 'form did not validate' );
+$form->process( secret => 'my_bar', params => { bar => 'my_bar', foo => 'my_foo' } );
+my @errors = $form->errors;
+is( $errors[0], 'Try again', 'form error' );
+$form->process( secret => 'my_foo', params => { bar => 'my_bar', foo => 'my_foo' } );
+ok( $form->validated, 'form validated' );
+ok( !$form->has_form_errors, 'form errors are gone' );
+
+done_testing;
diff --git a/t/xt/init.t b/t/xt/init.t
index d153ce6..4591559 100644
--- a/t/xt/init.t
+++ b/t/xt/init.t
@@ -21,6 +21,7 @@ use Test::More;
has_field 'reqname' => ( required => 1, default_over_obj => 'From Attribute' );
has_field 'altname' => ( traits => ['My::Default'] );
has_field 'somename';
+ has_field 'extraname' => ( default_over_obj => '' );
sub default_somename {
my $self = shift;
@@ -28,7 +29,9 @@ use Test::More;
}
}
-my $init_object = { reqname => 'Starting Perl', optname => 'Over Again', altname => 'test' };
+my $init_object = { reqname => 'Starting Perl', optname => 'Over Again', altname => 'test',
+ extraname => 'not_empty',
+};
my $form = My::Other::Form->new;
ok( $form, 'get form' );
my $params = { reqname => 'Sweet', optname => 'Charity', somename => 'Exists' };
@@ -40,6 +43,7 @@ is( $form->field('optname')->init_value, 'Over Again', 'correct init_value no m
is( $form->field('altname')->init_value, 'From Method', 'correct init_value from trait');
is( $form->field('somename')->init_value, 'SN from meth', 'correct for init_obj undef');
is( $form->field('somename')->value, 'Exists', 'correct value for init_obj undef');
+is( $form->field('extraname')->init_value, '', 'correct value for empty string default');
$form = My::Other::Form->new( init_object => $init_object );
is( $form->field('somename')->init_value, 'SN from meth', 'correct init_value new w init_obj');
diff --git a/t/xt/locale_data_localize.t b/t/xt/locale_data_localize.t
new file mode 100644
index 0000000..8860ea5
--- /dev/null
+++ b/t/xt/locale_data_localize.t
@@ -0,0 +1,56 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use HTML::FormHandler::Field::Text;
+
+BEGIN {
+ eval "use Data::Localize";
+ if ($@) {
+ plan skip_all => "Data::Localize is not installed";
+ }
+}
+
+{
+ package MyApp::Test::I18N::en_US;
+ our %Lexicon = (
+ 'You lost, insert coin' => 'Not won, coin needed',
+ 'Test field' => 'Grfg svryq',
+ );
+}
+
+{
+ package MyApp::Test::Form;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ sub _build_language_handle {
+ my $class = Moose::Meta::Class->create_anon_class(
+ superclasses => [ 'Data::Localize' ],
+ methods => {
+ maketext => sub { shift->localize(@_) }
+ }
+ );
+ my $loc = $class->new_object();
+ $loc->set_languages('en_US');
+ $loc->add_localizer(
+ class => "Namespace",
+ namespaces => [ "MyApp::Test::I18N" ],
+ );
+ return $loc;
+ }
+
+ has_field 'foo';
+ has_field 'bar';
+ sub validate_foo {
+ my ( $self, $field ) = @_;
+ $field->add_error('You lost, insert coin');
+ }
+}
+
+my $form = MyApp::Test::Form->new;
+ok( $form, 'form built' );
+$form->process( params => { foo => 'test' } );
+is( $form->field('foo')->errors->[0], 'Not won, coin needed', 'right message' );
+
+done_testing;
\ No newline at end of file
diff --git a/t/xt/mb_form.t b/t/xt/mb_form.t
new file mode 100644
index 0000000..92a298b
--- /dev/null
+++ b/t/xt/mb_form.t
@@ -0,0 +1,96 @@
+use strict;
+use warnings;
+use Test::More;
+
+{
+ package Hello::Form::Page;
+ use HTML::FormHandler::Moose;
+
+ extends 'HTML::FormHandler';
+
+ has '+html_prefix' => ( default => 0 );
+
+ has_field 'wizard_session_id' => ( type => 'Hidden' );
+ has_field 'cancel' => ( type => 'Submit', value => "Cancel" );
+ has_field 'prev' => ( type => 'Submit', value => "Prev" );
+ has_field 'next' => ( type => 'Submit', value => "Next" );
+}
+
+{
+ package Hello::Form::Page2;
+ use HTML::FormHandler::Moose;
+
+ extends 'Hello::Form::Page';
+
+ has_field 'organization' => ( type => 'Text' );
+
+ has_field 'mediums' => ( type => 'Repeatable', num_when_empty => 0 );
+ has_field 'mediums.id' => ( type => 'Integer' );
+ has_field 'mediums.tracklist' => ( type => 'Compound' );
+ has_field 'mediums.tracklist.id' => ( type => 'Integer' );
+ has_field 'mediums.tracklist.tracks' => ( type => 'Repeatable', num_when_empty => 0 );
+ has_field 'mediums.tracklist.tracks.id' => ( type => 'Integer' );
+}
+
+my $form = Hello::Form::Page2->new;
+ok( $form, 'form builds ok' );
+diag( $form->peek );
+diag( $form->result->peek );
+
+my $init_obj = {
+ mediums => [
+ {
+ id => 1,
+ tracklist => {
+ id => 10,
+ tracks => [
+ { id => 100 },
+ { id => 200 },
+ ],
+ },
+ },
+ {
+ id => 2,
+ tracklist => {
+ id => 20,
+ tracks => [
+ { id => 300 },
+ { id => 400 },
+ ],
+ },
+ },
+ ]
+};
+
+my $extra_values = {
+ 'next' => 'Next',
+ cancel => 'Cancel',
+ organization => undef,
+ prev => 'Prev',
+ wizard_session_id => undef,
+};
+
+
+$form->process( init_object => $init_obj );
+diag( $form->peek );
+diag( $form->result->peek );
+my $value = $form->value;
+is_deeply( $value, { %$init_obj, %$extra_values}, 'right values' );
+
+my $good_fif = {
+ 'mediums.0.id' => 1,
+ 'mediums.0.tracklist.id' => 10,
+ 'mediums.0.tracklist.tracks.0.id' => 100,
+ 'mediums.0.tracklist.tracks.1.id' => 200,
+ 'mediums.1.id' => 2,
+ 'mediums.1.tracklist.id' => 20,
+ 'mediums.1.tracklist.tracks.0.id' => 300,
+ 'mediums.1.tracklist.tracks.1.id' => 400,
+ 'organization' => '',
+ 'wizard_session_id' => '',
+};
+my $fif = $form->fif;
+is_deeply( $fif, $good_fif, 'fif is right' );
+$form->process( $fif );
+
+done_testing;
diff --git a/t/xt/posted.t b/t/xt/posted.t
new file mode 100644
index 0000000..16e4d23
--- /dev/null
+++ b/t/xt/posted.t
@@ -0,0 +1,59 @@
+use strict;
+use warnings;
+use Test::More;
+
+use HTML::FormHandler::I18N;
+$ENV{LANGUAGE_HANDLE} = HTML::FormHandler::I18N->get_handle('en_en');
+
+{
+ package Test::SingleBool;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+ has_field 'opt_in' => ( type => 'Boolean', required => 1 );
+}
+
+{
+ my $form = Test::SingleBool->new;
+ ok( $form, 'form built' );
+ $form->process( params => {} );
+ ok( !$form->ran_validation, 'form did not run validation' );
+
+ my $test = 'POST';
+ $form->process( posted => ($test eq 'POST'), params => {} );
+ ok( $form->ran_validation, 'form did run validation' );
+ ok( $form->has_errors, 'form has errors' );
+
+ my @errors = $form->errors;
+ is( scalar @errors, 1, 'form has an error' );
+ is( $errors[0], 'Opt in field is required', 'error message is correct' );
+}
+
+{
+ package Test::SingleBoolCompound;
+ use HTML::FormHandler::Moose;
+ extends 'HTML::FormHandler';
+
+
+ has_field 'a' => ( type => 'Compound', required => 1 );
+ has_field 'a.opt_in' => ( type => 'Boolean', required => 1 );
+}
+
+{
+ my $form = Test::SingleBoolCompound->new;
+ ok( $form, 'form built' );
+ $form->process( params => {} );
+ ok( !$form->ran_validation, 'form did not run validation' );
+
+ my $test = 'POST';
+ $form->process( posted => ($test eq 'POST'), params => {} );
+ ok( $form->ran_validation, 'form did run validation' );
+ ok( $form->has_errors, 'form has errors' );
+
+ my @errors = $form->errors;
+ is( scalar @errors, 1, 'form has an error' );
+ is( $errors[0], 'A field is required', 'error message is correct' );
+}
+
+done_testing;
+
diff --git a/t/xt/upload.t b/t/xt/upload.t
index 90e08db..5a687bb 100644
--- a/t/xt/upload.t
+++ b/t/xt/upload.t
@@ -13,22 +13,23 @@ use_ok('HTML::FormHandler::Field::Upload');
has filename => ( is => 'rw' );
has size => ( is => 'rw' );
- has tempname => ( is => 'rw' );
+ has tempname => ( is => 'rw', lazy_build => 1 );
has basename => ( is => 'ro', lazy_build => 1 );
- has fh => (
- is => 'rw',
- required => 1,
- lazy => 1,
- default => sub {
- my $self = shift;
- my $fh = IO::File->new( $self->tempname, IO::File::O_RDONLY );
- unless ( defined $fh ) {
- my $filename = $self->tempname;
- die "Can't open '$filename': '$!'";
- }
- return $fh;
- },
- );
+ has tmpdir => ( is => 'ro', default => '' );
+ has fh => ( is => 'rw', required => 1, lazy_build => 1 );
+ sub _build_fh {
+ my $self = shift;
+ my $fh = IO::File->new( $self->tempname, IO::File::O_RDONLY );
+ unless ( defined $fh ) {
+ my $filename = $self->tempname;
+ die "Can't open '$filename': '$!'";
+ }
+ return $fh;
+ }
+ sub _build_tempname {
+ my $self = shift;
+ return $self->tmpdir . $self->basename;
+ }
sub _build_basename {
my $self = shift;
@@ -75,7 +76,9 @@ use_ok('HTML::FormHandler::Field::Upload');
has_field 'submit' => ( type => 'Submit', value => 'Upload' );
}
+
my $form = My::Form::Upload->new;
+
ok( $form, 'created form with upload field' );
is( $form->field('file')->render, '
@@ -91,6 +94,25 @@ $upload->size( 20000000 );
$form->process( params => { file => $upload } );
ok( !$form->validated, 'form did not validate' );
+# file exists, is empty
+`touch temp.txt`;
+open ( my $fh, '>', 'temp.txt' );
+$form->process( params => { file => $fh } );
+my @errors = $form->errors;
+is( $errors[0], 'File uploaded is empty', 'empty file fails' );
+
+# file exists, is not empty
+print {$fh} "testing\n";
+close( $fh );
+open ( $fh, '<', 'temp.txt' );
+$form->process( params => { file => $fh } );
+ok( $form->validated, 'form validated' );
+
+# file doesn't exist
+$form->process( params => { file => 'not_there.txt' } );
+ at errors = $form->errors;
+is( $errors[0], 'File not found for upload field', 'error when file does not exist' );
+unlink('temp.txt');
done_testing;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libhtml-formhandler-perl.git
More information about the Pkg-perl-cvs-commits
mailing list