richter 02/03/06 23:12:31
Modified: Embperl/Form Tag: Embperl2c Validate.pm
Embperl/Form/Validate Tag: Embperl2c Default.pm Number.pm
Log:
form validation
Revision Changes Path
No revision
No revision
1.1.2.9 +270 -1122 embperl/Embperl/Form/Attic/Validate.pm
Index: Validate.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Attic/Validate.pm,v
retrieving revision 1.1.2.8
retrieving revision 1.1.2.9
diff -u -r1.1.2.8 -r1.1.2.9
--- Validate.pm 7 Mar 2002 04:41:06 -0000 1.1.2.8
+++ Validate.pm 7 Mar 2002 07:12:31 -0000 1.1.2.9
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Validate.pm,v 1.1.2.8 2002/03/07 04:41:06 richter Exp $
+# $Id: Validate.pm,v 1.1.2.9 2002/03/07 07:12:31 richter Exp $
#
###################################################################################
@@ -20,28 +20,35 @@
use strict;
use vars qw($VERSION);
-$VERSION = q$Id: Validate.pm,v 1.1.2.8 2002/03/07 04:41:06 richter Exp $;
+$VERSION = q$Id: Validate.pm,v 1.1.2.9 2002/03/07 07:12:31 richter Exp $;
=head1 NAME
-Embperl::Form::Validate - A generic (HTML) form validator with client-side-scripting
-support.
+Embperl::Form::Validate - Form validation with server- and client-side support.
=head1 DESCRIPTION
-This modules provides -- although bundled with EmbPerl -- a generic
-form validator, developed for server- (L<PERL CGI|CGI>,
-L<mod_perl|mod_perl>, L<Embperl|Embperl>, etc.) and client-side
-(JavaScript) web form validation.
+This modules is developed to do form validation for you. It works
+on the server side by checking the posted form data and it
+generates client side script functions, to validate the
+form values, as far as possible, before they are send to
+the server, to avoid another server roundtrip.
-It can be extended by new modules for different error messages
-sources, additional syntaxes (e.g. US zip codes, German
+Also it has the best support for Embperl, it should also work
+outside of Embperl e.g. with CGI.pm or mod_perl.
+
+It can be extended by new validation rules for
+additional syntaxes (e.g. US zip codes, German
Postleitzahlen, number plates, iso-3166 2-digit language or country
codes, etc.)
-Each module has the ability to rely it\'s answer on parameters like
+Each module has the ability to rely it's answer on parameters like
e.g. the browser, which caused the request for or submitted the form.
+The module fully supports internationalisation. Any message can be
+provided in multiple languages and it makes use of Embperl's
+multilanguage support.
+
=head1 SYNOPSIS
use Embperl::Form::Validate;
@@ -50,89 +57,66 @@
$epf->add_rule('fnord', $fnord_rules);
- # validate returns errors, so the form validates, if validate returns false
- my $result = $epf->validate($fdat, $pref);
+ # validate the form values and returns error information, if any
+ my $result = $epf -> validate ;
# Does the form content validate?
print 'Validate: ' . ($result?'no':'yes');
-
- # print all the error messages in the language 'de'
- foreach my $field (keys %$result) {
- foreach my $error (@{$result->{$field}}) {
- print $epf->generate_error_message($error,'de');
- }
- }
-
- # Get an array of all error messages
+
+ # validate the form values and reaturn all error messages, if any
my @errors = $epf->validate_messages($fdat, $pref);
- # Get the code for a client-side form verifier according the the
- # rules given in $rules:
-
- # Get the scripting code for given language/browser and with
- # JavaScript as language
- $epf->sprint_scripting_code($pref, 'javascript');
+ # Get the code for a client-side form validation according to the
+ # rules given to new:
+ $epf -> get_script_code ;
- # dito, but with defaultr scripting language (JavaScript)
- $epf->sprint_scripting_code($pref);
-
- # Get the JavaScript code with the default error message language (en)
- $epf->sprint_scripting_code('javascript');
-
- # Get the JavaScript code with the error messages in the language 'foo'
- $epf->sprint_scripting_code({Language => 'foo'}, 'javascript');
+=head1 METHODS
-=cut
+The following methods are available:
-#use Embperl::Form::Validate::Rules;
-use Embperl::Form::Validate::Messages;
+=head2 $epf = Embperl::Form::Validate -> new ($rules [, $form_id ],
[$default_language]);
-=pod
+Constructor for a new form validator. Returns a reference to a
+Embperl::Form::Validate object.
-=head1 METHODS
+=over
-The following methods are available:
+=item $rules
-=head2 $epf = new Embperl::Form::Validate($rules [, $form_id [, $msg_module]]);
+should be a reference to an array of rules, see L<"RULES"> elsewhere in this
+document for details.
-Constructor for the new form validator. Returns a reference to a
-Embperl::Form::Validate object.
+=item $form_id
-$form_id should be the name (im HTML) or id (in XHTML) parameter of
+should be the name (im HTML) or id (in XHTML) parameter of
the form tag, which has to be verified.It\'s e.g. used for
generating the right path in the JavaScript DOM. It defaults to 'forms[0]'
which should be the first form in your page.
-$rules should be hash of rules, see L<"RULES"> elsewhere in this
-document and L<Embperl::Form::Validate::Rules> for details.
+=item $default_language
-$msg_module should be hash of configuration commands for a
-L<Embperl::Form::Validate::Messages|Embperl::Form::Validate::Messages> object, if
you want to a
-different messages module than the default one
-(L<Embperl::Form::Validate::Messages::Default|Embperl::Form::Validate::Messages::Default>),
which just
-uses the messages of the L<Embperl::Form::Validate::Rules::*
modules|Embperl::Form::Validate::Rules>.
-See L<Embperl::Form::Validate::Messages> for details.
+language to use when no messages are available in the desired language.
+Defaults to 'en'.
+
+=back
=cut
-sub new # $self, \@frules, [$form_id,] [, \%messages ]
-{
+sub new
+ {
my $invokedby = shift;
my $class = ref($invokedby) || $invokedby;
- my ($frules, $form_id, $msgmod) = @_ ;
- # Determining, if there is an already existing Embperl::Form::Validate::Message
- # instance, which should be used
- my $msginstance = $msgmod->{instance} || new
Embperl::Form::Validate::Messages($msgmod);
+ my ($frules, $form_id, $default_language) = @_ ;
+
my $self = {
- form_id => $form_id || 'forms[0]', # The name (probably better
- # XPath) of the HTML form
- frules => $frules, # \%frules
- default_language => 'en',
+ form_id => $form_id || 'forms[0]', # The name
+ frules => $frules || [], # \@frules
+ default_language => $default_language || 'en',
};
bless($self, $class);
$self->init;
return $self;
-}
+ }
###
### init() yet undocumented. The only purpose of init() is too allow
@@ -150,114 +134,84 @@
Adds rules $field_rules for a (new) field $field to the validator,
e.g.
- $epf->add_rule('fnord', { type => 'Float', max => 1.3, name => 'Fnord' });
+ $epf->add_rule([ -key => 'fnord', -type => 'Float', -max => 1.3, -name => 'Fnord'
]);
-If there was already a rule for $field, it will be overwritten by the
-given rule(s).
+The new rule will be appended to the end of the list of rules.
See L<"RULES"> elsewhere in this document.
=cut
sub add_rule # $self, $field, \%rules
-{
+ {
my $self = shift;
- my $field = shift;
my $rules = shift;
- $self->{rules}->add_rule($field,$rules);
+
+ push @{$self->{frules}}, $rules;
return 1;
-}
+ }
-=head2 $epf->validate($fdat, $pref);
-Verifies the content $fdat according to the rules given to the
Embperl::Form::Validate
-constructor and added by $pef->add_rule() and returns a hash or hash
-reference (depending on the context) of error messages. The hash is
-empty or the reference undefined, if there were no errors, e.g.:
- $form_validates = not $epf->validate($fdat, $pref);
-$pref contains a hash reference with additional preferences like
-e.g. user agent. See L<"FDAT"> and L<"PREFERENCES"> elsewhere in this
-document.
+=head2 $epf -> validate ([$fdat, [$pref]]);
-#=cut
+Does the server-side form validation.
+=over
-#=pod
+=item $fdat
-sub validate # $self, \%fdat, \%pref
-{
- my $self = shift;
- my $fdat = shift;
- my $pref = shift; # e.g. User agent, output language, locale, etc.
- my %failed = ();
- my $frules = $self->{frules};
- foreach my $key (keys %$frules)
- {
- my $fkey = $fdat->{$key};
- # Is the field required
- my $fkrules = $frules->{$key};
- next if ($fkrules -> {emptyok} && $fkey eq '') ;
-
- my $required = $fkrules->{required};
- my $name = $fkrules->{name};
- if ($required and
- (!defined $fkey or $fkey eq '')) # '0' should still be ok.
- {
- if (!defined $fkey)
- {
- $failed{$key} =
- [[ 'required',
- $key,
- $name,
- '[required]',
- '[not present]',
- '[not present]',
- {
- en => 'Field $name is required but not present',
- de => 'Feld $name ist notwendig, aber nicht vorhanden'
- }
- ]];
- }
- elsif ($fkey eq '')
- {
- $failed{$key} =
- [[ 'required',
- $key,
- $name,
- '[required]',
- '[not present]',
- '[not present]',
- {
- en => 'Field $name is required but empty',
- de => 'Feld $name ist notwendig, aber nicht ausgef�llt'
- }
- ]];
- }
- next;
- }
- elsif (!defined $fkey || (!$required and $fkey eq ''))
- {
- next;
- }
- else
- {
- my @errormsgs = $self->{rules}->validate($key, $fkey, $pref, $fdat);
- if (@errormsgs) {
- $failed{$key} = \@errormsgs;
- }
- }
- }
- return (%failed ?
- (wantarray ?
- %failed :
- \%failed) :
- undef);
-}
+should be a hash reference to all postend form values.
+It defaults to %fdat of the current Embperl page.
+
+=item $pref
+
+can contain addtional information for the validation process.
+At the moment the keys C<language> and C<default_language>
+are recognized. C<language> defaults to the language set by
+Embperl. C<default_language> defaults to the one given with C<new>.
+
+=back
+
+The method verifies the content $fdat according to the rules given
+to the Embperl::Form::Validate
+constructor and added by the add_rule() method and returns an
+array refernce to error informations. If there is no error it
+returns undef. Each element of the returned array contains a hash with
+the following keys:
+
+=over
+
+=item key
+
+key into $fdat which caused the error
+
+=item id
+
+message id
+
+=item typeobj
+
+object reference to the Validate object which was used to validate the field
+
+=item name
+
+human readable name, if any. Maybe a hash with multiple languages.
+
+=item msg
+
+field specific messages, if any. Maybe a hash with multiple languages.
+
+=item param
+
+array with parameters which should subsituted inside the message
+
+=back
=cut
+
sub loadtype
{
my ($self, $type) = @_ ;
@@ -302,8 +256,6 @@
my $status ;
my $name ;
my $msg ;
- my $language = $pref -> {language} ;
- my $default_language = $pref -> {default_language} || 'en' ;
while ($i < @$frules)
{
@@ -315,9 +267,10 @@
}
elsif (ref $action eq 'CODE')
{
+ my $arg = $frules -> [$i++] ;
foreach my $k (@$keys)
{
- $status = &$action($k, $fdat -> {$name}, $frules, \$i, $fdat,
$pref) ;
+ $status = &$action($k, $fdat -> {$name}, $arg, $fdat, $pref) ;
last if (!$status) ;
}
}
@@ -346,7 +299,7 @@
$typeobj = $self -> newtype ($type) ;
foreach my $k (@$keys)
{
- $status = $typeobj -> validate ($k, $fdat -> {$k}, $frules, \$i,
$fdat, $pref) ;
+ $status = $typeobj -> validate ($k, $fdat -> {$k}, $fdat, $pref) ;
last if (!$status) ;
}
}
@@ -357,10 +310,11 @@
}
else
{
+ my $arg = $frules -> [$i++] ;
foreach my $k (@$keys)
{
my $method = 'validate_' . $action ;
- $status = $typeobj -> $method ($k, $fdat -> {$k}, $frules, \$i,
$fdat, $pref) ;
+ $status = $typeobj -> $method ($k, $fdat -> {$k}, $arg, $fdat,
$pref) ;
last if (!$status) ;
}
}
@@ -383,7 +337,10 @@
sub validate
{
- my ($self, $fdat, $pref) = @_ ;
+ my ($self, $fdat, $pref, $epreq) = @_ ;
+
+ $epreq ||= $Embperl::req ;
+ $fdat ||= $epreq -> thread -> fdat ;
my @result ;
$self -> validate_rules ($self->{frules}, $fdat, $pref, \@result) ;
@@ -434,11 +391,56 @@
}
-sub error_messages
+=pod
+
+=head2 $epf -> error_message ($err, [ $pref ])
+
+Converts one item returned by validate into a error message
+
+=over
+
+=item $err
+
+Item returned by validate
+
+=item $pref
+
+Preferences (see L<validate>)
+
+=back
+
+=cut
+
+
+sub error_message
+ {
+ my ($self, $err, $pref, $epreq) = @_ ;
+
+ $epreq ||= $Embperl::req ;
+
+ return $self -> build_message ($err -> {id}, $err -> {key}, $err -> {name},
$err -> {msg}, $err -> {param}, $err -> {typeobj}, $pref, $epreq) ;
+ }
+
+
+=pod
+
+=head2 $epf -> validate_messages ($fdat, [ $pref ])
+
+Validate the form content and returns the error messages
+if any. See L<validate> for details.
+
+=cut
+
+
+sub validate_messages
{
my ($self, $fdat, $pref, $epreq) = @_ ;
- my $result = $self -> validate ($fdat, $pref) ;
+ $epreq ||= $Embperl::req ;
+ $pref -> {language} ||= $epreq -> param -> language if ($epreq) ;
+ $pref -> {default_language} ||= $self -> {default_language} ;
+
+ my $result = $self -> validate ($fdat, $pref, $epreq) ;
return [] if (!@$result) ;
my @msgs ;
@@ -475,6 +477,7 @@
while ($i < @$frules)
{
+ my $arg ;
my $method ;
my $action = $frules -> [$i++] ;
if (ref $action eq 'ARRAY')
@@ -483,6 +486,7 @@
}
elsif (ref $action eq 'CODE')
{
+ $i++ ;
}
elsif ($action =~ /^-(.*?)$/)
{
@@ -517,6 +521,7 @@
else
{
$method = 'getscript_' . $action ;
+ $arg = $frules -> [$i++] ;
}
if ($method)
@@ -528,8 +533,7 @@
{
if ($typeobj -> can ($method))
{
- my $j = $i ;
- ($code, $msgparam) = $typeobj -> $method ($frules, \$i, $pref) ;
+ ($code, $msgparam) = $typeobj -> $method ($arg, $pref) ;
$scriptcode -> {$k} = [$code, $msgparam, $i - $j] ;
}
else
@@ -544,7 +548,6 @@
{
$code = $scriptcode -> {$k}[0] ;
$msgparam = $scriptcode -> {$k}[1] ;
- $i += $scriptcode -> {$k}[2] ;
}
}
@@ -591,17 +594,42 @@
}
+=pod
+
+=head2 $epf -> get_script_code ([$pref])
+
+Returns the script code necessary to do the client-side validation.
+Put the result between <SCRIPT> and </SCRIPT> tags inside your page.
+It will contain a function that is named C<epform_validate_<name_of_your_form>>
+where <name_of_your_form> is replaced by the form named you have passed
+to L<new>. You should call this function in the C<onSubmit> of your form.
+Example:
+
+ <script>
+ [+ do { local $escmode = 0 ; $epf -> get_script_code } +]
+ </script>
+
+ <form name="foo" action="POST" onSubmit="epform_validate_foo()">
+ ....
+ </form>
+
+=cut
sub get_script_code
{
my ($self, $pref, $epreq) = @_ ;
- $pref ||= {} ;
+ $epreq ||= $Embperl::req ;
+ $pref ||= {} ;
$pref -> {language} ||= $epreq -> param -> language if ($epreq) ;
+ $pref -> {default_language} ||= $self -> {default_language} ;
my $script ;
$script = $self -> gather_script_code ($self->{frules}, $pref, $epreq) ;
+ my $fname = $self -> {form_id} ;
+
+ $fname = s/([^a-zA-Z0-9_])/_/g ;
return qq{
@@ -624,1026 +652,146 @@
}
-=pod
-
- [
- -name => 'lang',
- -fail,
- required,
- length_max => 5,
-
- -name => 'xxx',
- -type => 'date',
- emptyok,
-
-
- -name => ['foo', 'bar']
- \&mysub,
-
-=cut
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-=head2 $epf->generate_error_message($error,$language);
-
-Generates a (usually :-) natural language form of the error array
-reference $error in $language (usually according to ISO-3166). See
-L<"ERROR CODES"> for details about the error arrays.
-
- my $error =
- [
- 'string_length_eq', # The id of the test, which failed
- 'bar', # The id of the form field, for which the test failed
- 'BAR', # The of the form field, for which the test failed
- # Should better be multi-lingual! Will be fixed soon.
- 23, # The $should value
- 3, # The $is value, here length($value)
- 'baz', # The content $value of the field
- # The error messages
- {
- 'de' => 'Inhalt des Feldes $name hat die falsche L�nge: Er sollte $should
Zeichen lang sein, ist aber $is lang',
- 'en' => 'Content of field $name has wrong length: It is $is characters long,
but should be $should characters long'
- }
- ];
- $error_msg_de = $epf->generate_error_message($error,'de');
-
-This returns the string "Inhalt des Feldes BAR hat die falsche L�nge:
-Er sollte 23 Zeichen lang sein, ist aber 3 lang".
-
-=cut
-
-sub generate_error_message # $self, $code, $language
-{
- my $self = shift;
- my ($id, $key, $name, $should, $is, $value, $msgs) = @{shift()};
- my $language = shift;
-
- # Form-local error message
- my $local_msg = $self->{frules}->{$key}->{messages}->{$language}->{$id};
- # Embperl::Form::Validate::Messages' error message
- my $msg_msg = $self->{msgmod}->get_error_message($id, $language);
- # The modul's default error message
- my $mod_msg = $msgs->{$language};
- # Constructing the right error message
- my $result;
- if ($result = $local_msg || $msg_msg || $mod_msg)
- {
- $result = insert_values($result, $key, $name, $should, $is, $value);
- }
- else
- {
- # No error message available in the requested language, find
- # the available ones and check if the default language is
- # under them.
- my %available_lang = ();
- my $m = $self->{frules}->{$key}->{messages};
- foreach my $l (keys %$m)
- {
- $available_lang{$l} = 1 if $m->{$l} && $l ne $language;
- }
- foreach my $l ($self->{msgmod}->get_languages())
- {
- $available_lang{$l} = 1
- if ($self->{msgmod}->get_error_message($id,$l) &&
- $l ne $language);
- }
- foreach my $l (keys %$msgs)
- {
- $available_lang{$l} = 1 if $msgs->{$l} && $l ne $language;
- }
- my $default_language = $self->{default_language};
- if ($available_lang{$default_language})
- {
- # Form-local error message
- $local_msg =
- $self->{frules}{$key}{messages}{$default_language}{$id};
- # Embperl::Form::Validate::Messages' error message
- $msg_msg =
- $self->{msgmod}->get_error_message($id, $default_language);
- # The modul's default error message
- $mod_msg = $msgs->{$default_language};
- # Constructing the right error message
- if ($result = $local_msg || $msg_msg || $mod_msg)
- {
- $result = insert_values($result, $key, $name, $should, $is, $value);
- }
- else
- {
- $result = "Generic Embperl::Form::Validate Error (error type is '$id')
in field '$name' (value '$value'): Required was '$should' but I got '$is'.\n[Found no
appropriate error message for language '$language' or default language
'$default_language'. Error messages for the error type '$id' are available in the
following languages: ".
- join(', ',keys %available_lang)."]";
- }
- }
- }
- return $result;
-}
-
-=head2 $epf->validate_messages($fdat, $pref);
-
-Verifies the content $fdat according to the rules given to the
Embperl::Form::Validate
-constructor and added by $pef->add_rule() and returns an array of
-already constructed error message string in language
-$pref->{Language}. The array is empty if there were no errors.
-
- @errors = $epf->validate_messages($fdat, $pref);
-
-See also L<"FDAT"> and L<"PREFERENCES"> elsewhere in this document.
-
-=cut
-
-sub validate_messages # $self, \%fdat, \%pref
-{
- my $self = shift;
- my $fdat = shift;
- my $pref = shift;
- my $language = $pref->{Language} || 'en';
- my $result = $self->validate($fdat, $pref);
- my @messages = ();
- foreach my $field (keys %$result)
- {
- foreach my $error (@{$result->{$field}})
- {
- push(@messages, $self->generate_error_message($error,$language));
- }
- }
- return @messages;
-}
-
-=head2 $epf->get_scripting_functions($pref, $script_lang);
-
-=head2 $epf->get_scripting_functions($script_lang);
-
-=head2 $epf->get_scripting_functions($pref);
-
-=head2 $epf->get_scripting_functions();
-
-Generates the code for the client-side scripting functions in the
-scripting language $script_lang (defaults to 'javascript') for the
-form and rules, to wichi $epf has been initialized.
-
-$pref can be used to return different scripting code for different
-user agents. It defaults to {}. See also L<"PREFERENCES"> elsewhere
-in this document.
-
-Returns an array reference with functions for all tests, but without
-inserted error messages. Format of each function is similar to format
-of L<ERROR CODES|"ERROR CODE">, which can be found elsewhere in this
-document.
-
-=cut
-
-sub get_scripting_functions # $self, \%pref, $script_lang
-{
- my $self = shift;
- # hash of additional information like user-agent, language for
- # error messages (ISO 3166), etc.:
- # User-Agent => 'CoolBrowser/3.14159265358',
- # Language => de
- my $pref;
- # Scripting Language, e.g. 'javascript', 'vbscript', etc.
- my $script_lang;
- if (scalar @_ == 1)
- {
- my $unknown = shift;
- if (ref $unknown eq 'HASH')
- {
- $pref = $unknown;
- }
- elsif (!ref $unknown)
- {
- $script_lang = $unknown;
- }
- else
- {
- die "Unknown parameter type to get_scripting_functions: $unknown";
- }
- }
- else
- {
- $pref = shift;
- $script_lang = shift;
- }
- $script_lang ||= 'javascript';
- my $language = $pref->{Language} || 'javascript';
- # Form specific rules
- my $frules = $self->{frules};
- # Hash of (existing) js-functions and substitution values:
- # test_id => [ 'js-code',
- # $should, $desc, $is, $value,
- # { lang1 => 'std_err_msg1', lang2 => 'std_err_msg2' } ]
- my %functions =
- $self->{rules}->get_scripting_functions($pref, $script_lang);
- # List of values to be returned
- my @result;
-
- ### DEBUG
- #use Data::Dumper; print '%form_local_msgs: '.Dumper
-
- # Hash of all tests, which have individual per-field error
- # messages:
- # field_name1 => { 'test_id1' => 'err_msg1',
- # 'test_id2' => 'err_msg2' }
- my %form_local_msgs;
-
- # Hash of prefixes per type (ignores currently the possibility of
- # forms defining different prefixes per field)
- # 'Embperl::Form::Validate::Rules::Type1' => 'type_'
- my %prefix;
- # Hash of hashes of all tests, which have (no) individual
- # per-field error messages:
- # 'Embperl::Form::Validate::Rules::Type1' => { 'test_id1' => 1,
- # 'test_id2' => 1,
- # 'test_idn' => 1 }
- my %has_form_global_msgs;
- my %has_form_local_msgs;
-
- # The final list of scripting functions
- my @functions;
-
- # And now: Generating them!
- foreach my $field_name (keys %$frules)
- {
- my $frtid = $frules->{$field_name};
- # Actual rules type
- my $type = $frtid->{type};
- $frtid = $type->new($frtid);
- # Its default prefix
- #use Data::Dumper;
- #print Dumper $frtid;
- my $p = $frtid->rules_prefix;
- # Its field-local error messages
- my $messages = $frtid->{messages}->{$language};
- # If we have field-local error messages
- if (defined $messages)
- {
- # Then store, which field has which type and error messages
-# $form_local_msgs{$field_name} = [ $type, $messages ];
- $form_local_msgs{$field_name} = $messages;
- # Also note that for which test of which rules type we
- # need to generate scripting functions with non-default
- # error messages
-# @{$has_form_local_msgs{$type}}{keys %$messages} =
-# (1)x keys %$messages;
- # All other used tests for that field will use the default
- # scripting functions, so we note that we need them
- my @keys = grep
- {
- # Weed out other parameters
- my $return = (field_name($_) &&
- # Weed out tests with field-local error messages
- !defined $messages->{$_} &&
- !defined $messages->{$p.$_});
- $_ = add_prefix($_,$p);
- # return, if belongs to that list for grep
- $return;
- }
- keys %$frtid;
- # Finally note that the tests in that list need global
- # versions of the scripting functions
- @{$has_form_global_msgs{$type}}{@keys} = (1)x@keys;
- }
- # If we have no field-local error messages, we note down, that
- # all tests need the global version of the scripting
- # functions.
- else
- {
- my @keys = grep
- {
- # Weed out other parameters
- my $return = field_name($_);
- # Add the type prefix, if not already there or global test
- s/^/$p/ if !/^$p/ && $_ ne 'required' && $_ ne 'emptyok';
- # return, if belongs to that list for grep
- $return;
- }
- keys %$frtid;
- # Finally note that the tests in that list need global
- # versions of the scripting functions
- @{$has_form_global_msgs{$type}}{@keys} = (1)x@keys;
- }
- }
-
- # Some DEBUG output
- #use Data::Dumper;
- #print '%has_form_global_msgs: '.Dumper {%has_form_global_msgs};
- #print '%has_form_local_msgs: '.Dumper {%has_form_local_msgs};
- #print '%form_local_msgs: '.Dumper {%form_local_msgs};
- #print '%functions: '.Dumper {%functions};
- # First let's insert the global error-messages into the code
- foreach my $type (keys %has_form_global_msgs)
- {
- my $test_ids = $has_form_global_msgs{$type};
- foreach my $test_id (keys %$test_ids)
- {
- # For some tests, it's not easy to write JS functions, so
- # they aren't written and therefore not in our functions
- # hash. We just skip them.
- next unless $functions{$test_id};
-
- #print "$test_id: ".Dumper $functions{$test_id}
- # if $test_id eq 'required';
- if ($test_ids->{$test_id})
- {
- # Copy the function (because we can't modify them
- # directly, because we still need the templates for
- # the functions with specific error messages)
- my ($func, $field, $desc, $should, $is, $value, $messages) =
- @{$functions{$test_id}};
-
- # Embperl::Form::Validate::Messages' error message
- my $msg_msg =
- $self->{msgmod}->get_error_message($test_id, $language);
- #print 'msgmod: '.Dumper $self->{msgmod};
-
- # The module's default error message, as delivered
- # with the function code.
- my $mod_msg = $messages->{$language};
- #print "modmsg: $type, $test_id";
- #print 'modmsg: '.Dumper $messages;
-
- # Constructing the right scripting function code
- if (my $error_message = $msg_msg || $mod_msg)
- {
- # Insert the default error message
- warn "No error message found *in* '$test_id'"
- unless $func =~
- s/(^|[^\\](\\\\)*)\$errormessage/$1$error_message/g;
- #print '*** '.Dumper \@func;
-
- # Insert the scripting code for the values to show
- # and push the resulting script code on the result
- # array:
-
- push(@functions,
- insert_values($func, $field, $desc, $should, $is, $value));
- }
- else
- {
- # No error message available in the requested
- # language, find the available ones and check if
- # the default language is under them.
-
- my %available_lang = ();
-
-# my $m = $frtid->{messages};
-# foreach my $l (keys %$m)
-# {
-# $available_lang{$l} = 1
-# if $m->{$l}{$test_id} && $l ne $language;
-# }
- foreach my $l ($self->{msgmod}->get_languages())
- {
- $available_lang{$l} = 1
- if ($self->{msgmod}->get_error_message($test_id,$l)
- && $l ne $language);
- }
- foreach my $l (keys %$messages)
- {
- $available_lang{$l} = 1
- if $messages->{$l} && $l ne $language;
- }
- my $default_language = $self->{default_language};
- if ($available_lang{$default_language})
- {
- #warn "Using default language '$default_language'";
- # Form-local error message
-# my $local_msg =
-# $self->{frules}{$key}{messages}{$default_language}{$id};
- # Embperl::Form::Validate::Messages' error message
- my $msg_msg =
- $self->{msgmod}->get_error_message($test_id,
- $default_language);
- # The modul's default error message
- $mod_msg = $messages->{$default_language};
- # Constructing the right error message
- if ($error_message =
- #$local_msg ||
- $msg_msg ||
- $mod_msg)
- {
- # Insert the default error message
- warn "No error message found *in* '$test_id'"
- unless $func =~
-
s/(^|[^\\](\\\\)*)\$errormessage/$1$error_message/g;
- #print '*** '.Dumper \@func;
-
- # Insert the scripting code for the values
- # to show and push the resulting script
- # code on the result array:
-
- push(@functions,
- insert_values($func, $field, $desc, $should, $is,
$value));
- }
- else
- {
- push(@functions,
- "Generic Embperl::Form::Validate Error (error type is
'$test_id') in field '$desc' (value '$value'): Required was '$should' but I got
'$is'.\n[Found no appropriate error message for language '$language' or default
language '$default_language'. Error messages for the error type '$test_id' are
available in the following languages: ".
- join(', ',keys %available_lang)."]");
- }
- }
- }
- }
- }
- }
+=head1 DATA STRUCTURES
- # Now let's insert the form-local error-messages into the code
- foreach my $key (keys %form_local_msgs)
- {
-# my $test_ids = $form_local_msgs{$key}[1];
- my $test_ids = $form_local_msgs{$key};
- foreach my $test_id (keys %$test_ids)
- {
- # For some tests, it's not easy to write JS functions, so
- # they aren't written and therefore not in our functions
- # hash. We just skip them.
- #print "*** Test: $test_id";
- next unless $functions{$test_id};
- #print "+++ Do: $test_id";
-
- #print "$test_id: ".Dumper $functions{$test_id}
- # if $test_id eq 'required';
- if ($test_ids->{$test_id})
- {
- # Copy the fuction (because we can't modify them
- # directly, because we still need the templates for
- # the functions with specific error messages)
- my ($func, $field, $desc, $should, $is, $value, $messages) =
- @{$functions{$test_id}};
-
- # Constructing the right scripting function code
- if (my $error_message = $form_local_msgs{$key}->{$test_id})
- {
- # Insert the error message
- warn "No error message found *in* '$key + $test_id'"
- unless $func =~
- s/(^|[^\\](\\\\)*)\$errormessage/$1$error_message/g;
- # Modify the function name
- warn "Could not modify scripting function: '$func'"
- unless $func =~
-
s/^\s*(function\s+(EPForm_validate_[_A-Za-z0-9]+))([\s\(])/$1_$key$3/m;
- #print '*** '.Dumper \@func;
-
- # Insert the scripting code for the values to show
- # and push the resulting script code on the result
- # array:
-
- push(@functions,
- insert_values($func, $field, $desc, $should, $is, $value));
-
- }
- else
- {
- warn "No error message found *for* '$key + $test_id'";
- }
- }
- }
- }
+The functions and methods expect the named data structures as follows:
+=head2 RULES
- # Some more DEBUG output
- #print '%has_form_global_msgs: '.Dumper {%has_form_global_msgs};
- #print '%has_form_local_msgs: '.Dumper {%has_form_local_msgs};
- #print '%functions: '.Dumper {%functions};
+The $rules array contains a list of tests to perform. Alls the given tests
+are process sequenzially. You can group tests together, so when one test fails
+the remaining of the same group are not processed.
- return [@functions];
-}
+ [
+ [
+ -key => 'lang',
+ -name => 'Language'
+ required => 1,
+ length_max => 5,
+ ],
+ [
+ -key => 'from',
+ -type => 'Date',
+ emptyok => 1,
+ ],
-=head2 $epf->get_scripting_calls($pref, $script_lang [, $key]);
+ -key => ['foo', 'bar']
+ required => 1,
+ ]
-=head2 $epf->get_scripting_calls($script_lang [, $key]);
-=head2 $epf->get_scripting_calls($pref [, $key]);
+All items starting with a dash are control elements, while all items
+without a dash are tests to perform.
-=head2 $epf->get_scripting_calls();
+=over
-Generates the code for the calls of the functions generated by the
-method get_scripting_functions() in the scripting language
-$script_lang (defaults to 'javascript') for the form and rules, to
-which $epf has been initialized.
+=item -key
-$pref can be used to return different scripting code for different
-user agents. It defaults to {}. See also L<"PREFERENCES"> elsewhere
-in this document.
+gives the key in the passed form data hash which should be tested. -key
+is normaly the name given in the HTML name attribute within a form field.
+C<-key> can also be a arrayref, in which case B<only one of> the given keys
+must statisfy the following test to succeed.
-The additional parameter $key may be used to narrow the returned list
-of functions.
+=item -name
-Returns an two-element array, of which the first element is an array
-reference to additional functions defined because of test dependencies
-and the second element contains an array reference of the function
-calls itself.
+is a human readable name that should be used in error messages. Can be
+hash with multiple languages, e.g.
-That array contains two type of elements:
+ -name => { 'en' => 'date', 'de' => 'Datum' }
- * scalars which are strings with independent functions calls
+=item -type
- * array references for functions calls just to be evaluated, if the
- field validates its required test. These arrays have the following
- structure:
+specfify to not use the standard tests, but the ones for a special type.
+For example there is a type C<Number> which will replaces all the comparsions
+by numeric ones instead of string comparisions. You may add your own types
+by wrting a module that contains the necessary test and dropping it under
+Embperl::Form::Validate::<Typename>. The -type directive also can verfiy
+that the given data has a valid format for the type.
- + first entry: field name
- + second entry: code for required test
+At the moment the only types that are available is C<Default> and C<Number>.
+The first is the default and need not to be specified. If you are writing new
+type make sure to send them back, so they can be part of the next distribution.
- + all other entries: code for the other tests, which depend on
- the required test
+=item -msg
-=cut
+Used to give messages which should be used when the test fails. This message
+overrides the standart messages provided by Embperl::Form::Validate and
+by Embperls message management. Can also be a hash with messages for multiple
+languages.
-sub get_scripting_calls # $self, \%pref, $script_lang [, $key ]
-{
- my $self = shift;
- # hash of additional information like user-agent, language for
- # error messages (ISO 3166), etc.:
- # User-Agent => 'CoolBrowser/3.14159265358',
- # Language => de
- my $pref;
- # Scripting Language, e.g. 'javascript', 'vbscript', etc.
- my $script_lang;
- # Any special selection of keys or tests?
- my $key;
- if (scalar @_ == 1)
- {
- my $unknown = shift;
- if (ref $unknown eq 'HASH')
- {
- $pref = $unknown;
- }
- elsif (!ref $unknown)
- {
- $script_lang = $unknown;
- }
- else
- {
- die "Unknown parameter type to get_scripting_calls: $unknown";
- }
- }
- else
- {
- $pref = shift;
- $script_lang = shift;
- $key = shift;
- }
- $script_lang ||= 'javascript';
- my $language = $pref->{Language} || 'en';
- # Some addtional variables
- my @keys;
- my %keys;
- my @calls;
- my $frules = $self->{frules};
-
- # If the second parameter is an array reference, take that array
- # as list of field names for which to generate scripting calls
- if (ref $key eq 'ARRAY')
- {
- #print '$key is array ref';
- @keys = @$key;
- }
-
- # Else if is is an hash reference, take that hash as field names
- # and functions for which to generate scripting calls
- elsif (ref $key eq 'HASH')
- {
- #print '$key is hash ref';
- @keys = keys %keys = %$key;
- }
-
- # Else if it is an scalar, take that value as sole field name for
- # which to generate the scripting call.
- elsif ($key && !ref $key)
- {
- #print '$key is scalar';
- @keys = ($key);
- }
+=item -fail
- # Else generate scripting calls for all fields which have tests.
- else
- {
- #print '$key is undef or scalar ref';
- @keys = keys %$frules;
- }
+stops further validation after the first error is found
- #use Data::Dumper;
- #print "keys = ".Dumper [@keys];
+=item -cont
- # Find out for which fields the calls should be generated
- foreach my $field (@keys)
- {
- my @ids;
- my $keyfield = $keys{$field};
- #print 'keyfield = '.Dumper $keyfield;
- my $ffrules = $frules->{$field};
- $ffrules = $ffrules->{type}->new($ffrules);
-
- # Find out for which tests the calls should be generated
- if (ref $keyfield eq 'ARRAY')
- {
- #print $field.': $keyfield is array ref';
- @ids = @$keyfield;
- }
- elsif (ref $keyfield eq 'HASH')
- {
- #print $field.': $keyfield is hash ref';
- @ids = grep { $keyfield->{$_} } keys %$keyfield;
- }
- elsif ($keyfield && !ref $keyfield)
- {
- #print $field.': $keyfield is scalar';
- @ids = ($keyfield);
- }
- else
- {
- #print $field.': $keyfield is undef or scalar ref';
- @ids = grep { field_name($_) } keys %$ffrules;
- }
- #print "$field: ids = ".Dumper [@ids];
- #print Dumper $ffrules;
-
- my $messages = $ffrules->{messages}{$language};
-
- # If there is a test 'required', it should be used before all
- # others for that field. And all those other should be used,
- # if that test fails, so we need to mark it somehow.
- my $required = grep { $_ eq 'required' } @ids;
- my $emptyok = grep { $_ eq 'emptyok' } @ids;
- # All calls for this field
- my @field_calls = ();
- if ($required)
- {
- #use Data::Dumper;
- #print Dumper [@ids];
- @ids = ('required', grep { $_ ne 'required' } @ids);
- @field_calls = ($field);
- #print Dumper [@ids];
- }
- elsif ($emptyok)
- {
- #use Data::Dumper;
- #print Dumper [@ids];
- @ids = ('emptyok', grep { $_ ne 'emptyok' } @ids);
- @field_calls = ($field);
- #print Dumper [@ids];
- }
-
- foreach my $test_id (@ids)
- {
- my $value = $ffrules->{$test_id};
- my $name = $ffrules->{name};
- $test_id = add_prefix($test_id,$ffrules->rules_prefix);
- my $script_functions_var = ($test_id eq 'required' || $test_id eq
'emptyok' ?
-
'Embperl::Form::Validate::Rules::script_functions' :
- ref($ffrules).'::script_functions');
- no strict 'refs';
- unless (defined ($$script_functions_var{$script_lang}{$test_id}))
- {
-# print "Ditching ".
-# $script_functions_var.'::'.$script_lang.'::'.$test_id;
- next;
- }
- use strict 'refs';
- # Local error message?
- if (defined $messages->{$test_id})
- {
- push(@field_calls,
- "EPForm_validate_".$test_id."_".$field.
- " (document.".$self->{form_id}.".".$field.
- ",'".$name."','".$value."')");
- }
- else
- {
- push(@field_calls,
- "EPForm_validate_".$test_id.
- " (document.".$self->{form_id}.".".$field.
- ",'".$name."','".$value."')");
- }
- }
-
- # We insert a array ref (with the field name as first and the
- # required test as second element), if we have a required, so
- # we know, that all test inside the referenced array may be
- # done only if the first succeeds.
- if ($required || $emptyok)
- {
- push(@calls, \@field_calls);
- }
- else
- {
- push(@calls, @field_calls);
- }
- }
- #use Data::Dumper;
- #print Dumper [@calls];
- return @calls;
-}
+continues validation in the same group, also a error was found
-=head2 $epf->sprint_scripting_code($pref, $script_lang [, $key]);
+=item [arrayref]
-=head2 $epf->sprint_scripting_code($script_lang [, $key]);
+you can place a arrayref with tests at any point in the rules list. The array will
+be considered as a group and the default is the stop processing of a group as soon
+as the first error is found and continue with processing with the next rules.
-=head2 $epf->sprint_scripting_code($pref [, $key]);
-
-=head2 $epf->sprint_scripting_code();
-
-Returns the code for the calls and functions ready to insert into a
-<SCRIPT> container or an ONSUBMIT parameter in the scripting language
-$script_lang (defaults to 'javascript') for the form and rules, to
-which $epf has been initialized.
-
-$pref can be used to return different scripting code for different
-user agents. It defaults to {}. See also L<"PREFERENCES"> elsewhere
-in this document.
-
-The additional parameter $key may be used to narrow the returned list
-of functions.
-
-Returns an two-element array, of which the first element is a string
-containing all to be defined scripting functions and the second
-element contains an expression, which verifies the form and returns a
-string of "\n" delimited error messages if there where errors. This
-return value e.g. can be easily feeded into a javascript alert() call.
-
-=cut
-
-sub sprint_scripting_code # $self, \%pref, $script_lang
-{
-###
-### INITIALIZATION
-###
- my $self = shift;
- # hash of additional information like user-agent, language for
- # error messages (ISO 3166), etc.:
- # User-Agent => 'CoolBrowser/3.14159265358',
- # Language => de
- my $pref;
- # Scripting Language, e.g. 'javascript', 'vbscript', etc.
- my $script_lang;
- if (scalar @_ == 1)
- {
- my $unknown = shift;
- if (ref $unknown eq 'HASH')
- {
- $pref = $unknown;
- }
- elsif (!ref $unknown)
- {
- $script_lang = $unknown;
- }
- else
- {
- die "Unknown parameter type to sprint_scripting_functions: $unknown";
- }
- }
- else
- {
- $pref = shift;
- $script_lang = shift;
- }
- $script_lang ||= 'javascript';
-###
-### The functions' code
-###
- my $functions =
- join("\n\n",@{$self->get_scripting_functions($pref,$script_lang)});
-###
-### The calls' code
-###
- # Initializing the both return values
- my $calls = '';
- # This won't be hardcoded later.
- #use Data::Dumper;
- if ($script_lang eq 'javascript')
- {
- my @calls = $self->get_scripting_calls($pref,$script_lang);
- for (my $i = 0; $i <= $#calls; $i++)
- {
- my $call = $calls[$i];
- #print '$call = '.Dumper $call;
- if (ref $call eq 'ARRAY')
- {
- my @field_calls = @$call;
- my $field = shift @field_calls;
- my $required = shift @field_calls;
- if (@field_calls)
- {
- my $field_calls = join(',',@field_calls);
- $functions .= "
-function EPForm_validate_required_$field ()
-{
- var wrong = $required;
- if (!wrong)
- {
- var test_array = new Array($field_calls);
- for (var Test in test_array)
- {
- if (test_array[Test])
- {
- wrong += test_array[Test] + '\\n';
- }
- }
- }
- if (wrong == '-')
- wrong = '' ;
- return wrong;
-}
-";
- $calls[$i] = "EPForm_validate_required_$field()";
- }
- else
- {
- $calls[$i] = $required;
- }
- }
- }
- $calls = '
-var test_array = new Array('. join(',',@calls).");
-var wrong = '';
-for (var Test in test_array)
-{
- if (test_array[Test])
- {
- wrong += test_array[Test] + '\\n';
- }
-}
-if (wrong && wrong != '-') alert(wrong);
-return !wrong;
-";
- }
- else
- {
- die "Yet unknown scripting language";
- }
-###
-### Returning functions' and calls' code
-###
- return ($functions, $calls);
-}
-
-
-
-###
-### insert_values inserts the values into the error messages
-###
-
-sub insert_values
-{
- # Inserts values into error messages
- my ($string, $field, $name, $should, $is, $value) = @_;
- $string =~ s/(^|[^\\](\\\\)*)\$field/$1$field/g if defined $field;
- $string =~ s/(^|[^\\](\\\\)*)\$name/$1$name/g if defined $name;
- $string =~ s/(^|[^\\](\\\\)*)\$should/$1$should/g if defined $should;
- $string =~ s/(^|[^\\](\\\\)*)\$is/$1$is/g if defined $is;
- $string =~ s/(^|[^\\](\\\\)*)\$value/$1$value/g if defined $value;
- return $string;
-}
-
-###
-### field_name returns true if $name doesn't match any not to test
-### hash key
-###
-
-sub field_name # $name
-{
- my $name = shift;
- return ($name ne 'type' &&
- $name ne 'rules_prefix' &&
- $name ne 'name' &&
- $name ne 'messages');
-}
+=back
-###
-### add_prefix adds a prefix, if there isn't already one.
-###
+The following test are currently defined:
-sub add_prefix # $name, $prefix
-{
- my $name = shift;
- my $prefix = shift;
- $name =~ s/^/$prefix/ if ($name !~ /^$prefix/) && $name ne 'required' && $name
ne 'emptyok';
- return $name
-}
+=over
-return 1;
+=item required
-=head1 DATA STRUCTURES
-
-The functions and methods expect the named data structures as follows:
+=item emptyok
-=head2 RULES
+=item length_min
-See also L<Embperl::Form::Validate::Rules>.
+=item length_max
-The $rules hash (reference) contains for each field to validate (the
-field names are the hash keys) the set of rules, which need to be
-verified. Each key and value pair of the per field hash (reference)
-contain the name of a test and the value to test against, except for
-the keys
+=item length_eq
-=over
+=item eq
-=item * 'type'
+=item ne
-contains the type of field, e.g. 'String' or 'Integer', required.
+=item lt
-=item * 'rules_prefix'
+=item gt
-contains the prefix for the error messages and scripting functions,
-e.g. 'string_', optional defaults to 'type'
+=item le
+=item ge
-=item * 'name'
+=item matches_regex
-contains the literal description of the field (e.g. 'zip code'),
-optional defaults to the name of the field
+=item matches_wildcard
+=item must_only_contain
-=item * 'messages'
+=item must_not_contain
-contains field specific error messages. optional.
+=item must_contain_one_of
=back
-Here\'s an example for some fictive rules:
-
- my $rules =
- { field1 => { type => 'String',
- name => 'Foo',
- matches_wildcard => '?oobar',
- messages =>
- { de => { string_eq =>
- 'Heh! Ich will sowas wie \'$should\' sehen!' },
- en => { string_eq =>
- 'Hey, I need something like \'$should\'?' }}},
- field2 => { type => 'Integer',
- name => 'Bar',
- required => 1,
- messages =>
- { de => { integer_min => 'Wert \'$value\' ist wirklich zu klein!',
- integer_max => 'Wert \'$value\' ist wirklich zu gro�!' },
- en => { integer_min => 'Value \'$value\' is really too small!',
- integer_max => 'Value \'$value\' is really too small!' }},
- min => 23,
- max => 42 }
- };
=head2 PREFERENCES
The $pref hash (reference) contains information about a single form
request or submission, e.g. the browser version, which made the
request or submission and the language in which the error messages
-should be returned.
-
-At the moment, Embperl::Form::Validate recognizes two keys: 'User-Agent' and
-'Language'.
+should be returned. See also L<validate>
-One idea is, to use values from the HTTP-Accept-Language-Header of the
-request for the value of the 'Language' key. Although problems arise,
-if there is more than one language present in that header.
-
- my $pref = { 'User-Agent' => 'Mozilla/0.9.5',
- 'Language' => 'de' };
=head2 ERROR CODES
-[Descriptions of the error codes, validate\'s returning]
-
- my $error_code = [...];
+For a descriptions of the error codes, validate is returning see L<validate>
-=head2 MESSAGE MODULES
-
-See L<Embperl::Form::Validate::Messages>.
-
- # use Embperl::Form::Validate::Messages::MyMessagesModule as source of default
messages
- my $msg_module = { module => 'MyMessagesModule' };
=head2 FDAT
See also L<Embperl>.
-[Descriptions of the fdat hash]
-
my $fdat = { foo => 'foobar',
bar => 'baz',
baz => 49,
@@ -1651,7 +799,7 @@
=head1 SEE ALSO
-See also L<Embperl::Form::Validate::Rules>, L<Embperl::Form::Validate::Messages>
and L<Embperl>.
+See also L<Embperl>.
=head1 AUTHOR
No revision
No revision
1.1.2.2 +45 -134 embperl/Embperl/Form/Validate/Attic/Default.pm
Index: Default.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Validate/Attic/Default.pm,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -r1.1.2.1 -r1.1.2.2
--- Default.pm 7 Mar 2002 04:41:07 -0000 1.1.2.1
+++ Default.pm 7 Mar 2002 07:12:31 -0000 1.1.2.2
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Default.pm,v 1.1.2.1 2002/03/07 04:41:07 richter Exp $
+# $Id: Default.pm,v 1.1.2.2 2002/03/07 07:12:31 richter Exp $
#
###################################################################################
@@ -20,7 +20,7 @@
use strict;
use vars qw($VERSION %error_messages %script_functions %prefixes);
-$VERSION = q$Id: Default.pm,v 1.1.2.1 2002/03/07 04:41:07 richter Exp $;
+$VERSION = q$Id: Default.pm,v 1.1.2.2 2002/03/07 07:12:31 richter Exp $;
%script_functions = ();
%prefixes = ();
@@ -108,7 +108,7 @@
sub validate_required
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
return defined($value) ? undef : ['validate_required'] ;
}
@@ -117,7 +117,7 @@
sub getscript_required
{
- my ($self, $frules, $i, $pref) = @_ ;
+ my ($self, $arg, $pref) = @_ ;
return ('!obj.value', ['validate_required']) ;
}
@@ -126,7 +126,7 @@
sub validate_emptyok
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
return defined($value) ? undef : [] ;
}
@@ -135,7 +135,7 @@
sub getscript_emptyok
{
- my ($self, $frules, $i, $pref) = @_ ;
+ my ($self, $arg, $pref) = @_ ;
return ('!obj.value') ;
}
@@ -144,60 +144,63 @@
sub validate_eq
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value eq $should ? undef : ['validate_eq', $value, $should] ;
+ return $value eq $arg ? undef : ['validate_eq', $value, $arg] ;
}
# --------------------------------------------------------------
sub getscript_eq
{
- my ($self, $frules, $i, $pref) = @_ ;
+ my ($self, $arg, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return ("obj.value == '$should'", ['validate_eq', "+'obj.value'+", $should]) ;
+ return ("obj.value == '$arg'", ['validate_eq', "+'obj.value'+", $arg]) ;
}
# --------------------------------------------------------------
sub validate_gt
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value gt $should ? undef : ['validate_gt', $value, $should] ;
+ return $value gt $arg ? undef : ['validate_gt', $value, $arg] ;
+ }
+
+# --------------------------------------------------------------
+
+sub getscript_gt
+ {
+ my ($self, $arg, $pref) = @_ ;
+
+ return ("obj.value < '$arg'", ['validate_gt', "+'obj.value'+", $arg]) ;
}
# --------------------------------------------------------------
sub validate_lt
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value lt $should ? undef : ['validate_lt', $value, $should] ;
+ return $value lt $arg ? undef : ['validate_lt', $value, $arg] ;
}
# --------------------------------------------------------------
sub validate_ge
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value ge $should ? undef : ['validate_ge', $value, $should] ;
+ return $value ge $arg ? undef : ['validate_ge', $value, $arg] ;
}
# --------------------------------------------------------------
sub validate_le
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value le $should ? undef : ['validate_le', $value, $should] ;
+ return $value le $arg ? undef : ['validate_le', $value, $arg] ;
}
@@ -205,69 +208,62 @@
sub validate_ne
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value ne $should ? undef : ['validate_ne', $value, $should] ;
+ return $value ne $arg ? undef : ['validate_ne', $value, $arg] ;
}
# --------------------------------------------------------------
sub validate_length_max
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return length($value) <= $should ? undef : ['validate_length_max',
length($value), $should] ;
+ return length($value) <= $arg ? undef : ['validate_length_max', length($value),
$arg] ;
}
# --------------------------------------------------------------
sub validate_length_min
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return length($value) >= $should ? undef : ['validate_length_min',
length($value), $should] ;
+ return length($value) >= $arg ? undef : ['validate_length_min', length($value),
$arg] ;
}
# --------------------------------------------------------------
sub getscript_length_min
{
- my ($self, $frules, $i, $pref) = @_ ;
+ my ($self, $arg, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return ("obj.value.length < $should", ['validate_length_min',
"'+obj.value.length+'", $should]) ;
+ return ("obj.value.length < $arg", ['validate_length_min',
"'+obj.value.length+'", $arg]) ;
}
# --------------------------------------------------------------
+
sub validate_length_eq
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return length($value) == $should ? undef : ['validate_length_eq',
length($value), $should] ;
+ return length($value) == $arg ? undef : ['validate_length_eq', length($value),
$arg] ;
}
# --------------------------------------------------------------
sub validate_matches_regex
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return ($value =~ /$should/) ? undef : ['validate_matches_regex', $value,
$should] ;
+ return ($value =~ /$arg/) ? undef : ['validate_matches_regex', $value, $arg] ;
}
# --------------------------------------------------------------
sub validate_matches_wildcard
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $wc, $fdat, $pref) = @_ ;
- my $wc = $frules -> [$$i++] ;
-
$wc =~ s/=/==/g;
$wc =~ s/(^|[^\\])\?/$1=./g;
$wc =~ s/([^\\])\*/$1=.=*/g;
@@ -281,9 +277,8 @@
sub validate_must_only_contain
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $moc, $fdat, $pref) = @_ ;
- my $moc = $frules -> [$$i++] ;
$moc =~ s/^\^(.)/$1^/;
$moc =~ s/^(.*)\]/\]$1/;
$moc =~ s/^(.*)-/-$1/;
@@ -295,9 +290,8 @@
sub validate_must_not_contain
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $mnc, $fdat, $pref) = @_ ;
- my $mnc = $frules -> [$$i++] ;
$mnc =~ s/^\^(.)/$1^/;
return ($value !~ /[$mnc]/) ? undef : ['validate_must_only_contain', $value,
$mnc] ;
}
@@ -307,95 +301,12 @@
sub validate_must_contain_one_of
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $mcoo, $fdat, $pref) = @_ ;
- my $mcoo = $frules -> [$$i++] ;
$mcoo =~ s/^\^(.)/$1^/;
return ($value =~ /[$mcoo]/) ? undef : ['validate_must_only_contain', $value,
$mcoo] ;
}
-
-
-sub rules_prefix # $self
-{
- my $self = shift;
- (my $rules_prefix = ref $self || $self) =~
- s/^.*::([^:]+)$/lc($1).'_'/e;
- return $rules_prefix;
-}
-
-
-
-### FUNCTIONS
-
-sub get_scripting_functions # $self, \@ids, \%pref, $script_lang
-{
- my $self = shift; # Used as if it were a method.
- my $ids = shift;
- # hash of additional information like user-agent, language for
- # error messages (ISO 3166), etc.:
- # User-Agent => 'CoolBrowser/3.14159265358',
- # Language => de
- my $pref;
- # Scripting Language, e.g. 'javascript', 'vbscript', etc.
- my $script_lang;
- # Any special selection of keys or tests?
- my $key;
- if (scalar @_ == 1)
- {
- my $unknown = shift;
- if (ref $unknown eq 'HASH')
- {
- $pref = $unknown;
- }
- elsif (!ref $unknown)
- {
- $script_lang = $unknown;
- }
- else
- {
- die "Unknown parameter type to get_scripting_functions: $unknown";
- }
- }
- else
- {
- $pref = shift;
- $script_lang = shift;
- $key = shift;
- }
- $script_lang ||= 'javascript';
- my %needed_functions;
- my $package = (ref $self || $self);
- foreach my $id (@$ids) {
- $id = $self->rules_prefix.$id;
- no strict 'refs';
- my $func = $ {$package . '::script_functions'}{$script_lang}{$id};
- use strict 'refs';
- if (defined $func) {
- push(@$func, $self->get_error_message_templates($id))
- unless ref $func->[4] eq 'HASH' ;
- $needed_functions{$id} = $func;
- }
- }
- return %needed_functions;
-}
-
-sub get_error_message_templates # $self, $id
-{
- my $self = shift; # Used as if it were a method.
- my $id = shift;
- my %result = ();
- my $package = (ref $self || $self);
- no strict 'refs';
- my $error_messages = \%{$package . '::error_messages'};
- use strict 'refs';
- foreach my $lang (keys %$error_messages)
- {
- $result{$lang} = $error_messages->{$lang}{$id};
- }
- return \%result;
-}
-
-return 1;
+1 ;
1.1.2.2 +47 -20 embperl/Embperl/Form/Validate/Attic/Number.pm
Index: Number.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Validate/Attic/Number.pm,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -r1.1.2.1 -r1.1.2.2
--- Number.pm 7 Mar 2002 04:41:07 -0000 1.1.2.1
+++ Number.pm 7 Mar 2002 07:12:31 -0000 1.1.2.2
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Number.pm,v 1.1.2.1 2002/03/07 04:41:07 richter Exp $
+# $Id: Number.pm,v 1.1.2.2 2002/03/07 07:12:31 richter Exp $
#
###################################################################################
@@ -20,57 +20,85 @@
use base qw(Embperl::Form::Validate::Default);
my
-$VERSION = q$Id: Number.pm,v 1.1.2.1 2002/03/07 04:41:07 richter Exp $;
+$VERSION = q$Id: Number.pm,v 1.1.2.2 2002/03/07 07:12:31 richter Exp $;
+my %error_messages =
+(
+ de =>
+ {
+ validate_number => '%0 mu� eine Zahl sein',
+ },
+
+ en =>
+ {
+ validate_number => '%0 must be a number',
+ }
+ );
+
+# --------------------------------------------------------------
+
+sub getmsg
+ {
+ my ($self, $id, $language, $default_language) = @_ ;
+
+ return $error_messages{$language}{$id} ||
+ $error_messages{$default_language}{$id} ||
+ $self -> SUPER::getmsg ($id, $language, $default_language) ;
+ }
+
+
+# --------------------------------------------------------------
+
+sub validate
+ {
+ my ($self, $key, $value, $fdat, $pref) = @_ ;
+
+ return $value =~ /^\s*[0-9.+-eE]+\s*$/ ? undef : ['validate_number', $value] ;
+ }
# --------------------------------------------------------------
sub validate_eq
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value == $should ? undef : ['validate_eq', $value, $should] ;
+ return $value == $arg ? undef : ['validate_eq', $value, $arg] ;
}
# --------------------------------------------------------------
sub validate_gt
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value > $should ? undef : ['validate_gt', $value, $should] ;
+ return $value > $arg ? undef : ['validate_gt', $value, $arg] ;
}
# --------------------------------------------------------------
sub validate_lt
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value < $should ? undef : ['validate_lt', $value, $should] ;
+ return $value < $arg ? undef : ['validate_lt', $value, $arg] ;
}
# --------------------------------------------------------------
sub validate_ge
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value >= $should ? undef : ['validate_ge', $value, $should] ;
+ return $value >= $arg ? undef : ['validate_ge', $value, $arg] ;
}
# --------------------------------------------------------------
sub validate_le
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value <= $should ? undef : ['validate_le', $value, $should] ;
+ return $value <= $arg ? undef : ['validate_le', $value, $arg] ;
}
@@ -78,10 +106,9 @@
sub validate_ne
{
- my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+ my ($self, $key, $value, $arg, $fdat, $pref) = @_ ;
- my $should = $frules -> [$$i++] ;
- return $value != $should ? undef : ['validate_ne', $value, $should] ;
+ return $value != $arg ? undef : ['validate_ne', $value, $arg] ;
}
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
