Advanced
Mailing List Archive

Mailing List Archive

  1. Home >
  2. ModPerl>
  3. Embperl-cvs
svn commit: r1912655 [2/2] - in /perl/embperl/trunk: ./ Embperl/ Embperl/Form/ Embperl/Form/Control/ Embperl/Form/Validate/
richter at apache
Oct 1, 2023, 6:06 AM
Post #1 of 1 (102 views)
Permalink
Modified: perl/embperl/trunk/Embperl/Form/Validate.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate.pm Sun Oct 1 13:06:43 2023
@@ -258,16 +258,14 @@ sub newtype

sub validate_rules
{
- my ($self, $frules, $fdat, $pref, $result) = @_ ;
+ my ($self, $frules, $fdat, $pref, $result, $key, $name) = @_ ;

my %param ;
my $type ;
my $typeobj ;
my $i ;
my $keys = [] ;
- my $key ;
my $status ;
- my $name ;
my $msg ;
my $break = 0 ;
my @key_stack ;
@@ -277,7 +275,7 @@ sub validate_rules
my $action = $frules -> [$i++] ;
if (ref $action eq 'ARRAY')
{
- my $fail = $self -> validate_rules ($action, $fdat, $pref, $result) ;
+ my $fail = $self -> validate_rules ($action, $fdat, $pref, $result, $key, $name) ;
return $fail if ($fail) ;
}
elsif (ref $action eq 'CODE')
@@ -294,7 +292,7 @@ sub validate_rules
if ($1 eq 'key')
{
$key = $frules->[$i++] ;
- $keys = ref $key?$key:[$key] ;
+ $keys = ref $key?$key:[$key] ;
$type = 'Default' ;
$typeobj = $self -> newtype ($type) ;
$name = undef ;
@@ -302,17 +300,26 @@ sub validate_rules
}
elsif ($1 eq 'key_check')
{
- push @key_stack, $key ;
+ push @key_stack, $key ;
$key = $frules->[$i++] ;
- $keys = ref $key?$key:[$key] ;
+ $keys = ref $key?$key:[$key] ;
$type = 'Default' ;
$typeobj = $self -> newtype ($type) ;
- $break = 1 ;
+ $break = 1 ;
}
elsif ($1 eq 'key_end')
{
- $key = pop @key_stack ;
- $break = 0 ;
+ $key = pop @key_stack ;
+ $keys = ref $key?$key:[$key] ;
+ $break = 0 ;
+ }
+ elsif ($1 eq 'frontend_only')
+ {
+ last ;
+ }
+ elsif ($1 eq 'backend_only')
+ {
+ ;
}
elsif ($1 eq 'name')
{
@@ -330,11 +337,11 @@ sub validate_rules
{
$type = $frules->[$i++] ;
$typeobj = $self -> newtype ($type) ;
- foreach my $k (@$keys)
- {
- $status = $typeobj -> validate ($k, $fdat -> {$k}, $fdat, $pref) ;
- last if (!$status) ;
- }
+ foreach my $k (@$keys)
+ {
+ $status = $typeobj -> validate ($k, $fdat -> {$k}, $fdat, $pref) ;
+ last if (!$status) ;
+ }
}
else
{
@@ -346,7 +353,7 @@ sub validate_rules
my $arg = $frules -> [$i++] ;
foreach my $k (@$keys)
{
- my $method = 'validate_' . $action ;
+ my $method = 'validate_' . $action ;
$status = $typeobj -> $method ($k, $fdat -> {$k}, $arg, $fdat, $pref) ;
last if (!$status) ;
}
@@ -390,8 +397,22 @@ sub build_message
my $default_language = $pref -> {default_language} || $self -> {default_language} ;
my $charset = $pref -> {charset} ;
my $txt ;
-
- $name ||= $epreq?$epreq -> gettext($key):$key ;
+ if ($name eq '')
+ {
+ if (!ref $key)
+ {
+ $name = $epreq?$epreq -> gettext('attr:' . $key):$key ;
+ }
+ else
+ {
+ my @name ;
+ foreach my $k (@$key)
+ {
+ push @name, $epreq?$epreq -> gettext('attr:' . $k):$k ;
+ }
+ $name = join (($language =~ /^de/)?' oder ':' or ', @name) ;
+ }
+ }
if (ref $name eq 'ARRAY')
{
my @names ;
@@ -409,6 +430,7 @@ sub build_message
if ($msg)
{
$txt = ref $msg ? ($msg -> {"$language.$charset"} || $msg -> {"$default_language.$charset"} || $msg -> {$language} || $msg -> {$default_language} || (each %$msg)[1] || undef):$msg ;
+ $txt = $epreq -> gettext ($msg) if ($epreq && ($msg =~ /^\w\w\w:/)) ;
}
else
{
@@ -506,16 +528,14 @@ sub validate_messages

sub gather_script_code
{
- my ($self, $frules, $pref, $epreq) = @_ ;
+ my ($self, $frules, $pref, $epreq, $key, $name) = @_ ;

my %param ;
my $type ;
my $typeobj ;
my $i ;
my $keys = [] ;
- my $key ;
my $status ;
- my $name ;
my $msg ;
my $msgparam ;
my $language = $pref -> {language} ;
@@ -533,7 +553,7 @@ sub gather_script_code
my $action = $frules -> [$i++] ;
if (ref $action eq 'ARRAY')
{
- $script .= $self -> gather_script_code ($action, $pref, $epreq) ;
+ $script .= $self -> gather_script_code ($action, $pref, $epreq, $key, $name) ;
}
elsif (ref $action eq 'CODE')
{
@@ -544,7 +564,7 @@ sub gather_script_code
if ($1 eq 'key')
{
$key = $frules->[$i++] ;
- $keys = ref $key?$key:[$key] ;
+ $keys = ref $key?$key:[$key] ;
$type = 'Default' ;
$typeobj = $self -> newtype ($type) ;
$name = undef ;
@@ -552,17 +572,25 @@ sub gather_script_code
}
elsif ($1 eq 'key_check')
{
- push @key_stack, $key ;
+ push @key_stack, $key ;
$key = $frules->[$i++] ;
- $keys = ref $key?$key:[$key] ;
+ $keys = ref $key?$key:[$key] ;
$type = 'Default' ;
$typeobj = $self -> newtype ($type) ;
- $break = 1 ;
+ $break = 1 ;
}
elsif ($1 eq 'key_end')
{
- $key = pop @key_stack ;
- $break = 0 ;
+ $key = pop @key_stack ;
+ $break = 0 ;
+ }
+ elsif ($1 eq 'frontend_only')
+ {
+ ;
+ }
+ elsif ($1 eq 'backend_only')
+ {
+ last ;
}
elsif ($1 eq 'name')
{
@@ -590,7 +618,7 @@ sub gather_script_code
}
else
{
- $method = 'getscript_' . $action ;
+ $method = 'getscript_' . $action ;
$arg = $frules -> [$i++] ;
}

@@ -932,6 +960,26 @@ errors only break current block, but doe
The above example will only require the field "input", when the field "action" is
not empty and is not zero.

+=item -key_check, -key_end
+
+Is used for preconditions, same example as for -break
+
+ [.
+ -key => 'input',
+ -key_check => 'action', emptyok => 1, ne => 0, -key_end,
+ 'required' => 1
+ ]
+
+The above example will only require the field "input", when the field "action" is
+not empty and is not zero.
+
+=item backend_only
+
+The following rules will only executed in the backend
+
+=item frontend_only
+
+The following rules will only executed in the fronend

=item [arrayref]


Modified: perl/embperl/trunk/Embperl/Form/Validate/DateTime.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/DateTime.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/DateTime.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/DateTime.pm Sun Oct 1 13:06:43 2023
@@ -17,12 +17,13 @@
package Embperl::Form::Validate::DateTime ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;

my %error_messages =
(
de =>
{
- validate_datetime_eu => 'Feld %0: "%1" ist kein g𬴩ges Zeitformat. Geben Sie die Zeit in der Form tt.mm.jjjj hh:mm:ss ein. Die Angabe der Zeit nach dem Datum ist optional.',
+ validate_datetime_eu => 'Feld %0: "%1" ist kein gültiges Zeitformat. Geben Sie die Zeit in der Form tt.mm.jjjj hh:mm:ss ein. Die Angabe der Zeit nach dem Datum ist optional.',
},

'de.utf-8' =>
@@ -56,12 +57,12 @@ sub validate

if($value =~ /^(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(.)$/)
{
- if ($4 < 1 || $4 > 31 ||
- $5 < 1 || $5 > 12 ||
- $6 < 1900 || $6 > 2100 ||
- $3 < 0 || $3 > 23 ||
- $4 < 0 || $4 > 59 ||
- $5 < 0 || $5 > 59)
+ if ($3 < 1 || $3 > 31 ||
+ $2 < 1 || $2 > 12 ||
+ $1 < 1900 || $1 > 2100 ||
+ $4 < 0 || $4 > 23 ||
+ $5 < 0 || $5 > 59 ||
+ $6 < 0 || $6 > 59)
{
return ['validate_datetime_eu', $value] ;
}

Modified: perl/embperl/trunk/Embperl/Form/Validate/DateTimeEU.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/DateTimeEU.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/DateTimeEU.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/DateTimeEU.pm Sun Oct 1 13:06:43 2023
@@ -1,44 +1,45 @@
-
-###################################################################################
-#
-# Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de
-# Embperl - Copyright (c) 2008-2014 Gerald Richter
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the Perl README file.
-#
-# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
-# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
-#
-###################################################################################
-
-
-package Embperl::Form::Validate::DateTimeEU ;
-
-use base qw(Embperl::Form::Validate::DateTime);
-
-
-# --------------------------------------------------------------
-
-sub validate
- {
- my ($self, $key, $value, $fdat, $pref) = @_ ;
-
- if($value =~ /^(\d{1:2})\.(\d{1:2})\.(\d{1:4})\s+(\d{1:2})\.(\d{1:2})\.(\d{1:4})$/)
- {
- if ($1 < 1 || $1 > 31 ||
- $2 < 1 || $2 > 12 ||
- $3 < 1900 || $3 > 2100 ||
- $4 < 0 || $4 > 23 ||
- $5 < 0 || $5 > 59 ||
- $6 < 0 || $6 > 59)
- {
- return ['validate_datetime_eu', $value] ;
- }
- return undef ;
- }
-
-
-
-1;
+
+###################################################################################
+#
+# Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de
+# Embperl - Copyright (c) 2008-2014 Gerald Richter
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+#
+# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+#
+###################################################################################
+
+
+package Embperl::Form::Validate::DateTimeEU ;
+
+use base qw(Embperl::Form::Validate::DateTime);
+use utf8 ;
+
+
+# --------------------------------------------------------------
+
+sub validate
+ {
+ my ($self, $key, $value, $fdat, $pref) = @_ ;
+
+ if($value =~ /^(\d{1:2})\.(\d{1:2})\.(\d{1:4})\s+(\d{1:2})\.(\d{1:2})\.(\d{1:4})$/)
+ {
+ if ($1 < 1 || $1 > 31 ||
+ $2 < 1 || $2 > 12 ||
+ $3 < 1900 || $3 > 2100 ||
+ $4 < 0 || $4 > 23 ||
+ $5 < 0 || $5 > 59 ||
+ $6 < 0 || $6 > 59)
+ {
+ return ['validate_datetime_eu', $value] ;
+ }
+ return undef ;
+ }
+
+
+
+1;

Modified: perl/embperl/trunk/Embperl/Form/Validate/Default.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/Default.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/Default.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/Default.pm Sun Oct 1 13:06:43 2023
@@ -18,6 +18,7 @@ package Embperl::Form::Validate::Default

use strict;
use vars qw($VERSION %error_messages %script_functions %prefixes);
+use utf8 ;

$VERSION = '2.0.0' ;


Modified: perl/embperl/trunk/Embperl/Form/Validate/Duration.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/Duration.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/Duration.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/Duration.pm Sun Oct 1 13:06:43 2023
@@ -17,6 +17,7 @@
package Embperl::Form::Validate::Duration ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;

my %error_messages =
(

Modified: perl/embperl/trunk/Embperl/Form/Validate/EMail.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/EMail.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/EMail.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/EMail.pm Sun Oct 1 13:06:43 2023
@@ -17,12 +17,13 @@
package Embperl::Form::Validate::EMail ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;

my %error_messages =
(
de =>
{
- validate_email => 'Die eingegebene E-Mail-Adresse "%0" in Feld "%1" ist ungültig, sie muß genau ein "@" enthalten und darf keine Leerzeichen, Klammern oder Umlaute enthalten.',
+ validate_email => 'Die eingegebene E-Mail-Adresse "%0" in Feld "%1" ist ung�ltig, sie mu� genau ein "@" enthalten und darf keine Leerzeichen, Klammern oder Umlaute enthalten.',
validate_email_nomailto => 'Die eingegebene E-Mail-Adresse "%0" in Feld "%1" scheint mit einem "mailto:" zu beginnen. Bitte geben Sie nur eine E-Mail-Adresse ein und keine mit "mailto:" beginnende URL.',
},

@@ -58,7 +59,7 @@ sub validate
my ($self, $key, $value, $fdat, $pref) = @_ ;

# The valid address "user@tld" or local addresses are not valid in this more general ruleset
- if ($value !~ /^[^ <>()@¡-ÿ]+@[^ <>()@¡-ÿ]+\.[a-zA-Z]{2,4}$/ or
+ if ($value !~ /^[^ <>()@�-�]+@[^ <>()@�-�]+\.[a-zA-Z]{2,4}$/ or
$value =~ /@(\.|.*(\.\.|@))/)
{
return ['validate_email', $value, $key] ;

Modified: perl/embperl/trunk/Embperl/Form/Validate/EMailRFC.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/EMailRFC.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/EMailRFC.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/EMailRFC.pm Sun Oct 1 13:06:43 2023
@@ -17,6 +17,7 @@
package Embperl::Form::Validate::EMailRFC ;

use base qw(Embperl::Form::Validate::EMail);
+use utf8 ;

# --------------------------------------------------------------


Modified: perl/embperl/trunk/Embperl/Form/Validate/FQDN.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/FQDN.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/FQDN.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/FQDN.pm Sun Oct 1 13:06:43 2023
@@ -16,12 +16,13 @@
package Embperl::Form::Validate::FQDN ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;

my %error_messages =
(
de =>
{
- validate_fqdn => 'Feld %0: "%1" ist keine gültiger Hostname.',
+ validate_fqdn => 'Feld %0: "%1" ist keine g�ltiger Hostname.',
},
en =>
{

Modified: perl/embperl/trunk/Embperl/Form/Validate/FQDN_IPAddr.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/FQDN_IPAddr.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/FQDN_IPAddr.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/FQDN_IPAddr.pm Sun Oct 1 13:06:43 2023
@@ -17,12 +17,13 @@
package Embperl::Form::Validate::FQDN_IPAddr ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;

my %error_messages =
(
de =>
{
- validate_fqdn_ipaddr => 'Feld %0: "%1" ist keine gültiger Hostname oder IP-Adresse.',
+ validate_fqdn_ipaddr => 'Feld %0: "%1" ist keine g�ltiger Hostname oder IP-Adresse.',
},

'de.utf-8' =>

Added: perl/embperl/trunk/Embperl/Form/Validate/FQDN_IPv4_IPv6Addr.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/FQDN_IPv4_IPv6Addr.pm?rev=1912655&view=auto
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/FQDN_IPv4_IPv6Addr.pm (added)
+++ perl/embperl/trunk/Embperl/Form/Validate/FQDN_IPv4_IPv6Addr.pm Sun Oct 1 13:06:43 2023
@@ -0,0 +1,123 @@
+
+###################################################################################
+#
+# Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de
+# Embperl - Copyright (c) 2008-2014 Gerald Richter
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+#
+# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+#
+###################################################################################
+
+
+package Embperl::Form::Validate::FQDN_IPv4_IPv6Addr ;
+
+use base qw(Embperl::Form::Validate::Default);
+use utf8 ;
+
+my %error_messages =
+(
+ de =>
+ {
+ validate_fqdn_ipv46addr => 'Feld %0: "%1" ist keine gütiger Hostname oder IP-Adresse.',
+ },
+
+ 'de.utf-8' =>
+ {
+ validate_fqdn_ipv46addr => 'Feld %0: "%1" ist keine gültiger Hostname oder IP-Adresse.',
+ },
+
+ en =>
+ {
+ validate_fqdn_ipv46addr => 'Field %0: "%1" isn\\\'t a valid hostname or ip-address.',
+ }
+ );
+
+
+# --------------------------------------------------------------
+
+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) ;
+ }
+
+
+# --------------------------------------------------------------
+
+=pod
+
+see https://stackoverflow.com/questions/53497/regular-expression-that-matches-valid-ipv6-addresses
+
+# IPv6 RegEx
+(
+([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}| # 1:2:3:4:5:6:7:8
+([0-9a-fA-F]{1,4}:){1,7}:| # 1:: 1:2:3:4:5:6:7::
+([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}| # 1::8 1:2:3:4:5:6::8 1:2:3:4:5:6::8
+([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}| # 1::7:8 1:2:3:4:5::7:8 1:2:3:4:5::8
+([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}| # 1::6:7:8 1:2:3:4::6:7:8 1:2:3:4::8
+([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}| # 1::5:6:7:8 1:2:3::5:6:7:8 1:2:3::8
+([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}| # 1::4:5:6:7:8 1:2::4:5:6:7:8 1:2::8
+[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})| # 1::3:4:5:6:7:8 1::3:4:5:6:7:8 1::8
+:((:[0-9a-fA-F]{1,4}){1,7}|:)| # ::2:3:4:5:6:7:8 ::2:3:4:5:6:7:8 ::8 ::
+fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}| # fe80::7:8%eth0 fe80::7:8%1 (link-local IPv6 addresses with zone index)
+::(ffff(:0{1,4}){0,1}:){0,1}
+((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}
+(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])| # ::255.255.255.255 ::ffff:255.255.255.255 ::ffff:0:255.255.255.255 (IPv4-mapped IPv6 addresses and IPv4-translated addresses)
+([0-9a-fA-F]{1,4}:){1,4}:
+((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}
+(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]) # 2001:db8:3:4::192.0.2.33 64:ff9b::192.0.2.33 (IPv4-Embedded IPv6 Address)
+)
+
+# IPv4 RegEx
+((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])
+
+=cut
+
+
+sub validate
+ {
+ my ($self, $key, $value, $fdat, $pref) = @_ ;
+
+ if ($value =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/)
+ {
+ if ($1 < 0 || $1 > 255 ||
+ $2 < 0 || $2 > 255 ||
+ $3 < 0 || $3 > 255 ||
+ $4 < 0 || $4 > 255)
+ {
+ return ['validate_fqdn_ipv46addr', $value] ;
+ }
+ else
+ {
+ return undef ;
+ }
+ }
+
+ return undef if ($value =~ /^[-.a-zA-Z0-9]+$/) ;
+
+ if ($value !~ /^(([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,7}:|([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}|([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}|([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}|([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})|:((:[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-fA-F]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))$/)
+ {
+ return ['validate_fqdn_ipv46addr', $value] ;
+ }
+ return undef;
+ }
+
+# --------------------------------------------------------------
+
+sub getscript_validate
+ {
+ my ($self, $arg, $pref) = @_ ;
+
+ return ('obj.value.search(/^[-.:a-zA-Z0-9]+$/) >= 0 ', ['validate_fqdn_ipv46addr', "'+obj.value+'"]) ;
+ }
+
+
+1;

Added: perl/embperl/trunk/Embperl/Form/Validate/IP6Addr_Mask.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/IP6Addr_Mask.pm?rev=1912655&view=auto
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/IP6Addr_Mask.pm (added)
+++ perl/embperl/trunk/Embperl/Form/Validate/IP6Addr_Mask.pm Sun Oct 1 13:06:43 2023
@@ -0,0 +1,73 @@
+
+###################################################################################
+#
+# Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de
+# Embperl - Copyright (c) 2008-2014 Gerald Richter
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+#
+# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+#
+###################################################################################
+
+
+package Embperl::Form::Validate::IP6Addr_Mask ;
+
+use base qw(Embperl::Form::Validate::Default);
+
+my %error_messages =
+(
+ de =>
+ {
+ validate_ip6addr_mask => 'Feld %0: "%1" ist keine gültige IP-Adresse. Geben Sie die IPv6-Adresse in der Form fe80::ffdf:3bae:884e:ba9a ein',
+ },
+
+ 'de.utf-8' =>
+ {
+ validate_ip6addr_mask => 'Feld %0: "%1" ist keine gültige IP-Adresse. Geben Sie die IPv6-Adresse in der Form fe80::ffdf:3bae:884e:ba9a ein',
+ },
+
+ en =>
+ {
+ validate_ip6addr_mask => 'Field %0: "%1" isn\\\'t a valid ip-address. Please enter the ipv6-address like fe80::ffdf:3bae:884e:ba9a',
+ }
+ );
+
+# --------------------------------------------------------------
+
+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) = @_ ;
+ if ($value !~ /^(([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,7}:|([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}|([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}|([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}|([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})|:((:[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-fA-F]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))$/)
+ {
+ return ['validate_ip6addr_mask', $value] ;
+ }
+ return undef;
+ }
+
+# --------------------------------------------------------------
+
+sub getscript_validate
+ {
+ my ($self, $arg, $pref) = @_ ;
+
+ return ('obj.value.search(/^(([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,7}:|([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}|([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}|([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}|([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})|:((:[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-fA-F]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))$/) >= 0', ['validate_ip6addr_mask', "'+obj.value+'"]) ;
+ }
+
+
+1;

Modified: perl/embperl/trunk/Embperl/Form/Validate/IPAddr.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/IPAddr.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/IPAddr.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/IPAddr.pm Sun Oct 1 13:06:43 2023
@@ -17,6 +17,7 @@
package Embperl::Form::Validate::IPAddr ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;

my %error_messages =
(
@@ -54,17 +55,17 @@ sub validate
{
my ($self, $key, $value, $fdat, $pref) = @_ ;

- if ($value =~ /^(\d+)\.(\d+).(\d+)\.(\d+)$/)
- {
- if ($1 < 0 || $1 > 255 ||
- $2 < 0 || $2 > 255 ||
- $3 < 0 || $3 > 255 ||
- $4 < 0 || $4 > 255)
- {
- return ['validate_ipaddr', $value] ;
- }
- return undef ;
- }
+ if ($value =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/)
+ {
+ if ($1 < 0 || $1 > 255 ||
+ $2 < 0 || $2 > 255 ||
+ $3 < 0 || $3 > 255 ||
+ $4 < 0 || $4 > 255)
+ {
+ return ['validate_ipaddr', $value] ;
+ }
+ return undef ;
+ }
return ['validate_ipaddr', $value] ;
}

@@ -74,7 +75,7 @@ sub getscript_validate
{
my ($self, $arg, $pref) = @_ ;

- return ('obj.value.search(/^\d+\.\d+.\d+.\d+$/) >= 0', ['validate_ipaddr', "'+obj.value+'"]) ;
+ return ('obj.value.search(/^\d+\.\d+\.\d+.\d+$/) >= 0', ['validate_ipaddr', "'+obj.value+'"]) ;
}



Modified: perl/embperl/trunk/Embperl/Form/Validate/IPAddr_Mask.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/IPAddr_Mask.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/IPAddr_Mask.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/IPAddr_Mask.pm Sun Oct 1 13:06:43 2023
@@ -17,6 +17,7 @@
package Embperl::Form::Validate::IPAddr_Mask ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;

my %error_messages =
(
@@ -54,13 +55,13 @@ sub validate
{
my ($self, $key, $value, $fdat, $pref) = @_ ;

- if ($value =~ /^(\d+)\.(\d+).(\d+)\.(\d+)\/(\d+)$/)
+ if ($value =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)\/(\d+)$/)
{
if ($1 < 0 || $1 > 255 ||
$2 < 0 || $2 > 255 ||
$3 < 0 || $3 > 255 ||
$4 < 0 || $4 > 255 ||
- $5 < 1 || $5 > 32)
+ $5 < 0 || $5 > 32)
{
return ['validate_ipaddr_mask', $value] ;
}

Added: perl/embperl/trunk/Embperl/Form/Validate/IPv6Addr.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/IPv6Addr.pm?rev=1912655&view=auto
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/IPv6Addr.pm (added)
+++ perl/embperl/trunk/Embperl/Form/Validate/IPv6Addr.pm Sun Oct 1 13:06:43 2023
@@ -0,0 +1,106 @@
+
+###################################################################################
+#
+# Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de
+# Embperl - Copyright (c) 2008-2014 Gerald Richter
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+#
+# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+#
+# $Id: IPAddr.pm 1578075 2014-03-16 14:01:14Z richter $
+#
+###################################################################################
+
+
+package Embperl::Form::Validate::IPv6Addr ;
+
+use base qw(Embperl::Form::Validate::Default);
+use utf8 ;
+
+my %error_messages =
+(
+ de =>
+ {
+ validate_ipv6addr => 'Feld %0: "%1" ist keine gültige IPv6-Adresse. Geben Sie die IP-Adresse in der Form n:n:.... ein',
+ },
+
+ 'de.utf-8' =>
+ {
+ validate_ipv6addr => 'Feld %0: "%1" ist keine gültige IPv6-Adresse. Geben Sie die IP-Adresse in der Form n:n:.... ein',
+ },
+
+ en =>
+ {
+ validate_ipv6addr => 'Field %0: "%1" isn\\\'t a valid ipv6-address. Please enter the ip-address as n:n:....',
+ }
+ );
+
+# --------------------------------------------------------------
+
+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) ;
+ }
+
+
+# --------------------------------------------------------------
+
+=pod
+
+see https://stackoverflow.com/questions/53497/regular-expression-that-matches-valid-ipv6-addresses
+
+# IPv6 RegEx
+(
+([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}| # 1:2:3:4:5:6:7:8
+([0-9a-fA-F]{1,4}:){1,7}:| # 1:: 1:2:3:4:5:6:7::
+([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}| # 1::8 1:2:3:4:5:6::8 1:2:3:4:5:6::8
+([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}| # 1::7:8 1:2:3:4:5::7:8 1:2:3:4:5::8
+([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}| # 1::6:7:8 1:2:3:4::6:7:8 1:2:3:4::8
+([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}| # 1::5:6:7:8 1:2:3::5:6:7:8 1:2:3::8
+([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}| # 1::4:5:6:7:8 1:2::4:5:6:7:8 1:2::8
+[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})| # 1::3:4:5:6:7:8 1::3:4:5:6:7:8 1::8
+:((:[0-9a-fA-F]{1,4}){1,7}|:)| # ::2:3:4:5:6:7:8 ::2:3:4:5:6:7:8 ::8 ::
+fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}| # fe80::7:8%eth0 fe80::7:8%1 (link-local IPv6 addresses with zone index)
+::(ffff(:0{1,4}){0,1}:){0,1}
+((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}
+(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])| # ::255.255.255.255 ::ffff:255.255.255.255 ::ffff:0:255.255.255.255 (IPv4-mapped IPv6 addresses and IPv4-translated addresses)
+([0-9a-fA-F]{1,4}:){1,4}:
+((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}
+(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]) # 2001:db8:3:4::192.0.2.33 64:ff9b::192.0.2.33 (IPv4-Embedded IPv6 Address)
+)
+
+# IPv4 RegEx
+((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])
+
+=cut
+
+
+sub validate
+ {
+ my ($self, $key, $value, $fdat, $pref) = @_ ;
+ if ($value !~ /^(([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,7}:|([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}|([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}|([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}|([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})|:((:[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-fA-F]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))$/)
+ {
+ return ['validate_ipv6addr', $value] ;
+ }
+ return undef;
+ }
+
+# --------------------------------------------------------------
+
+sub getscript_validate
+ {
+ my ($self, $arg, $pref) = @_ ;
+
+ return ('obj.value.search(/^(([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,7}:|([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}|([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}|([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}|([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})|:((:[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-fA-F]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))$/) >= 0', ['validate_ipv6addr', "'+obj.value+'"]) ;
+ }
+
+
+1;

Added: perl/embperl/trunk/Embperl/Form/Validate/IPv6Addr_Mask.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/IPv6Addr_Mask.pm?rev=1912655&view=auto
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/IPv6Addr_Mask.pm (added)
+++ perl/embperl/trunk/Embperl/Form/Validate/IPv6Addr_Mask.pm Sun Oct 1 13:06:43 2023
@@ -0,0 +1,110 @@
+
+###################################################################################
+#
+# Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh www.ecos.de
+# Embperl - Copyright (c) 2008-2014 Gerald Richter
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+#
+# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+#
+# $Id: IPAddr_Mask.pm 1578075 2014-03-16 14:01:14Z richter $
+#
+###################################################################################
+
+
+package Embperl::Form::Validate::IPv6Addr_Mask ;
+
+use base qw(Embperl::Form::Validate::Default);
+use utf8 ;
+
+my %error_messages =
+(
+ de =>
+ {
+ validate_ipv6addr_mask => 'Feld %0: "%1" ist keine gültige IPv6-Adresse/Netzmaske. Geben Sie die IP-Adresse/Netzmaske in der Form n:n:..../mm ein',
+ },
+
+ 'de.utf-8' =>
+ {
+ validate_ipv6addr_mask => 'Feld %0: "%1" ist keine gültige IPv6-Adresse/Netzmaske. Geben Sie die IP-Adresse/Netzmaske in der Form n:n:..../mm ein',
+ },
+
+ en =>
+ {
+ validate_ipv6addr_mask => 'Field %0: "%1" isn\\\'t a valid ipv6-address/netmask. Please enter the ip-address/netmask as n:n:..../mm',
+ }
+ );
+
+# --------------------------------------------------------------
+
+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) ;
+ }
+
+
+# --------------------------------------------------------------
+
+=pod
+
+see https://stackoverflow.com/questions/53497/regular-expression-that-matches-valid-ipv6-addresses
+
+# IPv6 RegEx
+(
+([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}| # 1:2:3:4:5:6:7:8
+([0-9a-fA-F]{1,4}:){1,7}:| # 1:: 1:2:3:4:5:6:7::
+([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}| # 1::8 1:2:3:4:5:6::8 1:2:3:4:5:6::8
+([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}| # 1::7:8 1:2:3:4:5::7:8 1:2:3:4:5::8
+([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}| # 1::6:7:8 1:2:3:4::6:7:8 1:2:3:4::8
+([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}| # 1::5:6:7:8 1:2:3::5:6:7:8 1:2:3::8
+([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}| # 1::4:5:6:7:8 1:2::4:5:6:7:8 1:2::8
+[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})| # 1::3:4:5:6:7:8 1::3:4:5:6:7:8 1::8
+:((:[0-9a-fA-F]{1,4}){1,7}|:)| # ::2:3:4:5:6:7:8 ::2:3:4:5:6:7:8 ::8 ::
+fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}| # fe80::7:8%eth0 fe80::7:8%1 (link-local IPv6 addresses with zone index)
+::(ffff(:0{1,4}){0,1}:){0,1}
+((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}
+(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])| # ::255.255.255.255 ::ffff:255.255.255.255 ::ffff:0:255.255.255.255 (IPv4-mapped IPv6 addresses and IPv4-translated addresses)
+([0-9a-fA-F]{1,4}:){1,4}:
+((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}
+(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]) # 2001:db8:3:4::192.0.2.33 64:ff9b::192.0.2.33 (IPv4-Embedded IPv6 Address)
+)
+
+# IPv4 RegEx
+((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])
+
+=cut
+
+
+sub validate
+ {
+ my ($self, $key, $value, $fdat, $pref) = @_ ;
+ if ($value !~ /^(?:(?:[0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|(?:[0-9a-fA-F]{1,4}:){1,7}:|(?:[0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|(?:[0-9a-fA-F]{1,4}:){1,5}(?::[0-9a-fA-F]{1,4}){1,2}|(?:[0-9a-fA-F]{1,4}:){1,4}(?::[0-9a-fA-F]{1,4}){1,3}|(?:[0-9a-fA-F]{1,4}:){1,3}(?::[0-9a-fA-F]{1,4}){1,4}|(?:[0-9a-fA-F]{1,4}:){1,2}(?::[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:(?:(?::[0-9a-fA-F]{1,4}){1,6})|:(?:(?::[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(?::[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(?:ffff(?::0{1,4}){0,1}:){0,1}(?:(?:25[0-5]|(?:2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(?:25[0-5]|(?:2[0-4]|1{0,1}[0-9]){0,1}[0-9])|(?:[0-9a-fA-F]{1,4}:){1,4}:(?:(?:25[0-5]|(?:2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(?:25[0-5]|(?:2[0-4]|1{0,1}[0-9]){0,1}[0-9]))\/([0-9]{1,3})$/)
+ {
+ return ['validate_ipv6addr_mask', $value] ;
+ }
+ if ($1 < 0 || $1 > 128)
+ {
+ return ['validate_ipv6addr_mask', $value] ;
+ }
+ return undef;
+ }
+
+# --------------------------------------------------------------
+
+sub getscript_validate
+ {
+ my ($self, $arg, $pref) = @_ ;
+
+ return ('obj.value.search(/^(([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,7}:|([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}|([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}|([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}|([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})|:((:[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-fA-F]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))\/([0-9]{1,3})$/) >= 0', ['validate_ipv6addr_mask', "'+obj.value+'"]) ;
+ }
+
+
+1;

Modified: perl/embperl/trunk/Embperl/Form/Validate/Number.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/Number.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/Number.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/Number.pm Sun Oct 1 13:06:43 2023
@@ -17,6 +17,7 @@
package Embperl::Form::Validate::Number ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;

my
$VERSION = '2.0.0' ;

Modified: perl/embperl/trunk/Embperl/Form/Validate/PosInteger.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/PosInteger.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/PosInteger.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/PosInteger.pm Sun Oct 1 13:06:43 2023
@@ -17,6 +17,7 @@
package Embperl::Form::Validate::PosInteger ;

use base qw(Embperl::Form::Validate::Integer);
+use utf8 ;

my %error_messages =
(

Modified: perl/embperl/trunk/Embperl/Form/Validate/Select.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/Select.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/Select.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/Select.pm Sun Oct 1 13:06:43 2023
@@ -17,6 +17,7 @@
package Embperl::Form::Validate::Select ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;


# --------------------------------------------------------------

Modified: perl/embperl/trunk/Embperl/Form/Validate/TimeHHMM.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/TimeHHMM.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/TimeHHMM.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/TimeHHMM.pm Sun Oct 1 13:06:43 2023
@@ -17,6 +17,7 @@
package Embperl::Form::Validate::TimeHHMM ;

use base qw(Embperl::Form::Validate::Default);
+use utf8 ;

my %error_messages =
(

Modified: perl/embperl/trunk/Embperl/Form/Validate/TimeValue.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Form/Validate/TimeValue.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Form/Validate/TimeValue.pm (original)
+++ perl/embperl/trunk/Embperl/Form/Validate/TimeValue.pm Sun Oct 1 13:06:43 2023
@@ -17,6 +17,7 @@
package Embperl::Form::Validate::TimeValue ;

use base qw(Embperl::Form::Validate::Integer);
+use utf8 ;

my %error_messages =
(

Modified: perl/embperl/trunk/Embperl/Inline.pm
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/Embperl/Inline.pm?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/Embperl/Inline.pm (original)
+++ perl/embperl/trunk/Embperl/Inline.pm Sun Oct 1 13:06:43 2023
@@ -11,8 +11,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id$
-#
+
###################################################################################



Modified: perl/embperl/trunk/MANIFEST
URL: http://svn.apache.org/viewvc/perl/embperl/trunk/MANIFEST?rev=1912655&r1=1912654&r2=1912655&view=diff
==============================================================================
--- perl/embperl/trunk/MANIFEST (original)
+++ perl/embperl/trunk/MANIFEST Sun Oct 1 13:06:43 2023
@@ -57,6 +57,10 @@ Embperl/Form/Validate/EMailRFC.pm
Embperl/Form/Validate/FQDN_IPAddr.pm
Embperl/Form/Validate/IPAddr.pm
Embperl/Form/Validate/IPAddr_Mask.pm
+Embperl/Form/Validate/FQDN_IPv4_IPv6Addr.pm
+Embperl/Form/Validate/IP6Addr_Mask.pm
+Embperl/Form/Validate/IPv6Addr.pm
+Embperl/Form/Validate/IPv6Addr_Mask.pm
Embperl/Form/Validate/Integer.pm
Embperl/Form/Validate/PosInteger.pm
Embperl/Form/Validate/Select.pm



---------------------------------------------------------------------
To unsubscribe, e-mail: embperl-cvs-unsubscribe@perl.apache.org
For additional commands, e-mail: embperl-cvs-help@perl.apache.org

©2024 GT.net. A Gossamer Threads company.
5th Floor, 455 Granville St., Vancouver, BC V6C 1T1, Canada | Legal