richter 02/03/05 13:55:23
Modified: . Tag: Embperl2c Embperl.pm
Embperl/Form Tag: Embperl2c Validate.pm
Embperl/Form/Validate/Rules Tag: Embperl2c Default.pm
Integer.pm
Log:
form validation
Revision Changes Path
No revision
No revision
1.118.4.95 +6 -3 embperl/Embperl.pm
Index: Embperl.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl.pm,v
retrieving revision 1.118.4.94
retrieving revision 1.118.4.95
diff -u -r1.118.4.94 -r1.118.4.95
--- Embperl.pm 4 Mar 2002 11:44:49 -0000 1.118.4.94
+++ Embperl.pm 5 Mar 2002 21:55:23 -0000 1.118.4.95
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Embperl.pm,v 1.118.4.94 2002/03/04 11:44:49 richter Exp $
+# $Id: Embperl.pm,v 1.118.4.95 2002/03/05 21:55:23 richter Exp $
#
###################################################################################
@@ -40,6 +40,7 @@
$req_rec
$importno
%initparam
+ $modperl
) ;
@@ -47,6 +48,8 @@
$VERSION = '2.0b6_dev-2' ;
+$modperl = $ENV{MOD_PERL} ;
+
if ($ENV{PERL_DL_NONLAZY}
&& substr($ENV{GATEWAY_INTERFACE} || '', 0, 8) ne 'CGI-Perl'
&& defined &DynaLoader::boot_DynaLoader)
@@ -61,7 +64,7 @@
{
bootstrap Embperl $VERSION;
Boot ($VERSION) ;
- Init (defined(&Apache::server)?Apache -> server:undef, \%initparam) ;
+ Init ($modperl?Apache -> server:undef, \%initparam) ;
}
$cwd = Cwd::fastcwd();
@@ -129,7 +132,7 @@
use strict ;
-if (defined ($ENV{MOD_PERL}))
+if ($Embperl::modperl)
{
eval 'use Apache::Constants qw(&OPT_EXECCGI &DECLINED &OK &FORBIDDEN)' ;
die "use Apache::Constants failed: $@" if ($@);
No revision
No revision
1.1.2.6 +92 -27 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.5
retrieving revision 1.1.2.6
diff -u -r1.1.2.5 -r1.1.2.6
--- Validate.pm 5 Mar 2002 15:59:20 -0000 1.1.2.5
+++ Validate.pm 5 Mar 2002 21:55:23 -0000 1.1.2.6
@@ -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.5 2002/03/05 15:59:20 richter Exp $
+# $Id: Validate.pm,v 1.1.2.6 2002/03/05 21:55:23 richter Exp $
#
###################################################################################
@@ -20,7 +20,7 @@
use strict;
use vars qw($VERSION);
-$VERSION = q$Id: Validate.pm,v 1.1.2.5 2002/03/05 15:59:20 richter Exp $;
+$VERSION = q$Id: Validate.pm,v 1.1.2.6 2002/03/05 21:55:23 richter Exp $;
=head1 NAME
@@ -84,7 +84,7 @@
=cut
-use Embperl::Form::Validate::Rules;
+#use Embperl::Form::Validate::Rules;
use Embperl::Form::Validate::Messages;
=pod
@@ -184,9 +184,11 @@
e.g. user agent. See L<"FDAT"> and L<"PREFERENCES"> elsewhere in this
document.
-=cut
+#=cut
+
+
+#=pod
-=pod
sub validate # $self, \%fdat, \%pref
{
my $self = shift;
@@ -256,16 +258,13 @@
\%failed) :
undef);
}
+
=cut
sub loadtype
{
my ($self, $type) = @_ ;
- my $type = shift;
- $type ||= 'Default';
- $type = 'Embperl::Form::Validate::Rules::'.$type
- unless $type =~ m!(::|/)!;
eval "require $type;";
die 'Died inside '.__PACKAGE__.'::loadtype::eval: '.$@ if $@;
@@ -276,11 +275,15 @@
sub newtype
{
my ($self, $type) = @_ ;
- my $type = shift;
+
+ $type ||= 'Default';
+ $type = 'Embperl::Form::Validate::Rules::'.$type
+ unless $type =~ m!(::|/)!;
+
my $obj = $self -> {typeobjs}{$type} ;
return $obj if ($obj) ;
- $self -> loadtype ($type) ;
+ $type = $self -> loadtype ($type) ;
$obj = $self -> {typeobjs}{$type} = $type -> new ;
@@ -291,42 +294,64 @@
sub validate_rules
{
- my ($self, $fdat, $pref) = @_ ;
+ my ($self, $frules, $fdat, $pref, $result) = @_ ;
my %param ;
my $type ;
my $typeobj ;
+ my $i ;
+ my $keys = [] ;
+ my $key ;
+ my $status ;
+ my $name ;
+ my $msg ;
+ my $language = $pref -> {language} ;
+ my $default_language = $pref -> {default_language} || 'en' ;
- my $frules = $self->{frules};
while ($i < @$frules)
{
- my $key = $frules -> [$i++] ;
- if (ref $key eq 'ARRAY')
+ my $action = $frules -> [$i++] ;
+ if (ref $action eq 'ARRAY')
{
- my $fail = $self -> validate_rules ($key, $fdat, $pref, $result) ;
+ my $fail = $self -> validate_rules ($action, $fdat, $pref, $result) ;
return $fail if ($fail) ;
}
- elsif (ref $key eq 'CODE')
+ elsif (ref $action eq 'CODE')
{
- foreach my $name (@$names)
+ foreach my $k (@$keys)
{
- $status = &$key($self, $name, $fdat -> {$name}, $frules, \$i,
$fdat, $pref) ;
+ $status = &$action($k, $fdat -> {$name}, $frules, \$i, $fdat,
$pref) ;
last if (!$status) ;
}
}
- elsif ($key =~ /^-(.*?)$/)
+ elsif ($action =~ /^-(.*?)$/)
{
+ if ($1 eq 'key')
+ {
+ $key = $frules->[$i++] ;
+ $keys = ref $key?$key:[$key] ;
+ $type = 'Default' ;
+ $typeobj = $self -> newtype ($type) ;
+ $name = undef ;
+ $msg = undef ;
+ }
if ($1 eq 'name')
{
- $name = $frules->[$i++] ;
- $type = 'Default' ;
- $typeobj = $self -> newtype ($type) ;
+ $name = $i++ ;
+ }
+ if ($1 eq 'msg')
+ {
+ $msg = $i++ ;
}
elsif ($1 eq 'type')
{
$type = $frules->[$i++] ;
$typeobj = $self -> newtype ($type) ;
- $status = $typeobj -> validate ($self, $name, $fdat -> {$name},
$frules, \$i, $fdat, $pref) ;
+ foreach my $k (@$keys)
+ {
+ $status = $typeobj -> validate ($k, $fdat -> {$name}, $frules,
\$i, $fdat, $pref) ;
+ last if (!$status) ;
+ }
}
else
{
@@ -335,16 +360,37 @@
}
else
{
- foreach my $name (@$names)
+ foreach my $k (@$keys)
{
- $status = $type -> $key ($self, $name, $fdat -> {$name}, $frules,
\$i, $fdat, $pref) ;
+ my $method = 'validate_' . $action ;
+ $status = $typeobj -> $method ($k, $fdat -> {$k}, $frules, \$i,
$fdat, $pref) ;
last if (!$status) ;
}
}
if ($status)
{
- push @$result, $status
+ if (@$status)
+ {
+ my $txt ;
+ my $id = $status -> [0] ;
+
+ my $n = $key ;
+ $n = $frules -> [$name] if ($name) ;
+ $status -> [0] = ref $n ? ($n -> {$language} || $n ->
{$default_language} || (each %$n)[1] || $key):$n ;
+
+ if ($msg)
+ {
+ my $m = $frules -> [$msg] ;
+ $txt = ref $m ? ($m -> {$language} || $m -> {$default_language}
|| (each %$m)[1] || undef):$m ;
+ }
+ else
+ {
+ $txt = $typeobj -> getmsg ($id, $language, $default_language) ;
+ }
+
+ push @$result, { id => $id, key => $key, ($txt?(msg => $txt):()),
param => $status} ;
+ }
last if (!$param{cont})
}
}
@@ -362,6 +408,25 @@
$self -> validate_rules ($self->{frules}, $fdat, $pref, \@result) ;
return \@result ;
+ }
+
+
+sub error_messages
+ {
+ my ($self, $fdat, $pref) = @_ ;
+
+ my $result = $self -> validate ($fdat, $pref) ;
+ return [] if (!@$result) ;
+
+ my @msgs ;
+ foreach my $err (@$result)
+ {
+ my $msg = $err -> {msg} || 'Unknown error in %1: is %1 should %2' ;
+ $msg =~ s/%(\d+)/$err->{param}[$1]/g ;
+ push @msgs, $msg ;
+ }
+
+ return \@msgs ;
}
No revision
No revision
1.1.2.3 +233 -26 embperl/Embperl/Form/Validate/Rules/Attic/Default.pm
Index: Default.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Validate/Rules/Attic/Default.pm,v
retrieving revision 1.1.2.2
retrieving revision 1.1.2.3
diff -u -r1.1.2.2 -r1.1.2.3
--- Default.pm 5 Mar 2002 15:59:31 -0000 1.1.2.2
+++ Default.pm 5 Mar 2002 21:55:23 -0000 1.1.2.3
@@ -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.2 2002/03/05 15:59:31 richter Exp $
+# $Id: Default.pm,v 1.1.2.3 2002/03/05 21:55:23 richter Exp $
#
###################################################################################
@@ -20,54 +20,261 @@
use strict;
use vars qw($VERSION %error_messages %script_functions %prefixes);
-$VERSION = q$Id: Default.pm,v 1.1.2.2 2002/03/05 15:59:31 richter Exp $;
+$VERSION = q$Id: Default.pm,v 1.1.2.3 2002/03/05 21:55:23 richter Exp $;
-%error_messages = ();
%script_functions = ();
%prefixes = ();
-sub new # $self, \%frkey
-{
+%error_messages =
+(
+ de =>
+ {
+ validate_eq => 'Falscher Inhalt \'%1\' des Feldes %0: Erwartet wird \'%2\'',
+ validate_lt => '%0 mu� kleiner als %2 sein',
+ validate_gt => '%0 mu� gr��er als %2 sein',
+ validate_le => '%0 mu� kleiner oder gleich wie %2 sein',
+ validate_ge => '%0 mu� gr��er oder gleich %2 sein',
+ validate_ne => '%0 mu� ungleich %2 sein',
+ validate_length_max => 'Inhalt des Feldes %0 ist zu lang, maximale L�nge sind
%2, eingegeben wurden %1 Zeichen',
+ validate_length_min => 'Inhalt des Feldes %0 ist zu kurz, minimal L�nge sind
%2, eingegeben wurden %1 Zeichen',
+ validate_length_eq => 'Inhalt des Feldes %0 hat die falsche L�nge: Er sollte
%2 Zeichen lang sein, ist aber %1 lang',
+ validate_matches_regexp => 'Inhalt \'%1\' des Feldes %0 entspricht nicht dem
regul�ren Ausdruck /%2/',
+ validate_matches_wildcard => 'Inhalt \'%1\' des Feldes %0 entspricht nicht dem
Wildcard-Ausdruck \'%2\'',
+ validate_must_only_contain => 'Das Feld %0 darf nur folgende Zeichen
enthalten: \'%2\'',
+ validate_must_contain_one_of => 'Das Feld %0 mu� mindestens eines der
folgenden Zeichen enthalten: \'%2\'',
+ validate_must_not_contain => 'Das Feld %0 darf folgende Zeichen nicht
enthalten: \'%2\''
+ },
+
+ en =>
+ {
+ validate_eq => 'Wrong content \'%1\' of field %0: Expected \'%2\'',
+ validate_lt => '%0 must be less then %2',
+ validate_gt => '%0 must be greater then %2',
+ validate_le => '%0 must be less or equal then %2',
+ validate_ge => '%0 must be greater or equal then %2',
+ validate_ne => 'Wrong content \'%1\' of field %0: Expected not \'%2\'',
+ validate_length_max => 'Content of field %0 is too long, has %1 characters,
maximum is %2 characters',
+ validate_length_min => 'Content of field %0 is too short, has %1 characters,
minimum is %2 characters',
+ validate_length_eq => 'Content of field %0 has wrong length: It is %1
characters long, but should be %2 characters long',
+ validate_matches_regexp => 'Field %0 doesn\'t match regexp /%2/',
+ validate_matches_wildcard => 'Field %0 doesn\'t match wildcard expression
\'%2\'',
+ validate_must_only_contain => 'Field %0 must contain only the following
characters: \'%2\'',
+ validate_must_contain_one_of => 'Field %0 must contain one of the following
characters: \'%2\'',
+ validate_must_not_contain => 'Field %0 must not contain the following
characters: \'%2\''
+ }
+ );
+
+
+
+# --------------------------------------------------------------
+
+sub new
+ {
my $invokedby = shift;
my $class = ref($invokedby) || $invokedby;
- my $self = shift;
+ my $self = {} ;
bless($self, $class);
$self->init;
return $self;
-}
+ }
+
+# --------------------------------------------------------------
+
+sub getmsg
+ {
+ my ($self, $id, $language, $default_language) = @_ ;
+
+ return $error_messages{$language}{$id} ||
$error_messages{$default_language}{$id} ;
+ }
+
+# --------------------------------------------------------------
sub init
-{
+ {
my $self = shift;
return 1;
-}
+ }
-sub validate # $self, $string, \%pref, \%fdat
-{
- my $self = shift;
+# --------------------------------------------------------------
+
+sub validate
+ {
return undef ;
-}
+ }
+
+# --------------------------------------------------------------
+
+sub validate_required
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ return defined($value) ? undef : ['validate_required'] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_emptyok
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ return defined($value) ? undef : [] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_eq
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value eq $should ? undef : ['validate_eq', $value, $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_gt
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value gt $should ? undef : ['validate_gt', $value, $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_lt
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value lt $should ? undef : ['validate_lt', $value, $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_ge
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value ge $should ? undef : ['validate_ge', $value, $should] ;
+ }
+# --------------------------------------------------------------
+sub validate_le
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value le $should ? undef : ['validate_le', $value, $should] ;
+ }
+
+
+# --------------------------------------------------------------
+
+sub validate_ne
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value ne $should ? undef : ['validate_ne', $value, $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_length_max
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return length($value) <= $should ? undef : ['validate_length_max',
length($value), $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_length_min
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return length($value) >= $should ? undef : ['validate_length_min',
length($value), $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_length_eq
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return length($value) == $should ? undef : ['validate_length_eq',
length($value), $should] ;
+ }
+# --------------------------------------------------------------
-sub eq
-{
- my ($self, $validate, $name, $value, $frules, $i, $fdat, $pref) = @_ ;
+sub validate_matches_regex
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
my $should = $frules -> [$$i++] ;
- return undef if ($value eq $should) ;
+ return ($value =~ /$should/) ? undef : ['validate_matches_regex', $value,
$should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_matches_wildcard
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $wc = $frules -> [$$i++] ;
+
+ $wc =~ s/=/==/g;
+ $wc =~ s/(^|[^\\])\?/$1=./g;
+ $wc =~ s/([^\\])\*/$1=.=*/g;
+ $wc =~ s/([^\\])([][])/$1=$2/g;
+ $wc =~ s/=(.)/$1/g;
+
+ return ($value =~ /$wc/) ? undef : ['validate_matches_wildcard', $value, $wc] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_must_only_contain
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $moc = $frules -> [$$i++] ;
+ $moc =~ s/^\^(.)/$1^/;
+ $moc =~ s/^(.*)\]/\]$1/;
+ $moc =~ s/^(.*)-/-$1/;
+ return ($value =~ /^[$moc]$/) ? undef : ['validate_must_only_contain', $value,
$moc] ;
+ }
+
- return [ 'string_eq',
- $key,
- $name,
- $self->{eq},
- $string,
- $string,
- $self->get_error_message_templates('string_eq')
- ]
- );
+# --------------------------------------------------------------
+
+sub validate_must_not_contain
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $mnc = $frules -> [$$i++] ;
+ $mnc =~ s/^\^(.)/$1^/;
+ return ($value !~ /[$mnc]/) ? undef : ['validate_must_only_contain', $value,
$mnc] ;
}
+
+
+# --------------------------------------------------------------
+
+sub validate_must_contain_one_of
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $mcoo = $frules -> [$$i++] ;
+ $mcoo =~ s/^\^(.)/$1^/;
+ return ($value =~ /[$mcoo]/) ? undef : ['validate_must_only_contain', $value,
$mcoo] ;
+ }
+
1.1.2.2 +70 -2 embperl/Embperl/Form/Validate/Rules/Attic/Integer.pm
Index: Integer.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Validate/Rules/Attic/Integer.pm,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -r1.1.2.1 -r1.1.2.2
--- Integer.pm 27 Feb 2002 15:42:50 -0000 1.1.2.1
+++ Integer.pm 5 Mar 2002 21:55:23 -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: Integer.pm,v 1.1.2.1 2002/02/27 15:42:50 richter Exp $
+# $Id: Integer.pm,v 1.1.2.2 2002/03/05 21:55:23 richter Exp $
#
###################################################################################
@@ -20,7 +20,75 @@
use base qw(Embperl::Form::Validate::Rules::Default);
my
-$VERSION = q$Id: Integer.pm,v 1.1.2.1 2002/02/27 15:42:50 richter Exp $;
+$VERSION = q$Id: Integer.pm,v 1.1.2.2 2002/03/05 21:55:23 richter Exp $;
+
+
+# --------------------------------------------------------------
+
+sub validate_eq
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value == $should ? undef : ['validate_eq', $key, $value, $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_gt
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value > $should ? undef : ['validate_gt', $key, $value, $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_lt
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value < $should ? undef : ['validate_lt', $key, $value, $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_ge
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value >= $should ? undef : ['validate_ge', $key, $value, $should] ;
+ }
+
+# --------------------------------------------------------------
+
+sub validate_le
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value <= $should ? undef : ['validate_le', $key, $value, $should] ;
+ }
+
+
+# --------------------------------------------------------------
+
+sub validate_ne
+ {
+ my ($self, $key, $value, $frules, $i, $fdat, $pref) = @_ ;
+
+ my $should = $frules -> [$$i++] ;
+ return $value != $should ? undef : ['validate_ne', $key, $value, $should] ;
+ }
+
+
+=pod
+
+
+
sub validate # $self, $integer, $key, \%pref
{
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
