modified version check

[selfforum.git] / selfforum-cgi / shared / CheckRFC.pm

diff --git a/selfforum-cgi/shared/CheckRFC.pm b/selfforum-cgi/shared/CheckRFC.pm
index ddde67f6a569d163698514f4e6278d806739b5ea..b43d723ff9e326d81a01712ae54d6756c416ec67 100644 (file)
--- a/selfforum-cgi/shared/CheckRFC.pm
+++ b/selfforum-cgi/shared/CheckRFC.pm
@@ -4,7 +4,7 @@ package CheckRFC;
 #                                                                              #
 # File:        shared/CheckRFC.pm                                              #
 #                                                                              #
 #                                                                              #
 # File:        shared/CheckRFC.pm                                              #
 #                                                                              #

-# Authors:     Andre Malo       <nd@o3media.de>, 2001-04-14                    #
+# Authors:     André Malo <nd@o3media.de>                                      #

 #                                                                              #
 # Description: implement several string checks on RFC correctness              #
 #                                                                              #
 #                                                                              #
 # Description: implement several string checks on RFC correctness              #
 #                                                                              #


@@ -26,6 +26,16 @@ $v56 = eval q[
 
 use Carp qw(croak);
 
 
 use Carp qw(croak);
 

+################################################################################
+#
+# Version check
+#
+# last modified:
+#    $Date$ (GMT)
+# by $Author$
+#
+sub VERSION {(q$Revision$ =~ /([\d.]+)\s*$/)[0] or '0.0'}
+

 ################################################################################
 #
 # Export
 ################################################################################
 #
 # Export


@@ -51,27 +61,30 @@ require Exporter;
 #
 # Return: Status code (Bool)
 #
 #
 # Return: Status code (Bool)
 #

-sub is_URL ($@) {
+sub is_URL (;$@) {

   my ($string, @schemes) = @_;
   my ($string, @schemes) = @_;

+  $string = $_ unless defined $string;
+  my $scheme;

 
   return unless (defined ($string) and length ($string));
 
   @schemes = qw(http) unless (@schemes);
   @schemes = keys %url if (@schemes == 1 and $schemes[0] eq ':ALL');
 
 
   return unless (defined ($string) and length ($string));
 
   @schemes = qw(http) unless (@schemes);
   @schemes = keys %url if (@schemes == 1 and $schemes[0] eq ':ALL');
 

-  for (@schemes) {
-    croak "unknown url scheme '$_'" unless exists $url{$_};
-    unless (/mailto/) {
-      return 1 if ($string =~ /$url{$_}/);
+  for $scheme (@schemes) {
+    croak "unknown url scheme '$scheme'" unless exists $url{$scheme};
+    unless ($scheme =~ /mailto/) {
+      return 1 if ($string =~ /$url{$scheme}/);

     }
     else {
     }
     else {

-      return unless ($string =~ /^mailto:(.+)/);
-
-      if ($_ eq 'mailto') {
-        return 1 if (is_email ($1));
-      }
-      elsif ($_ eq 'strict_mailto') {
-        return 1 if (is_email ($1,1));
+      if ($string =~ /^mailto:(.+)/) {
+
+        if ($scheme eq 'mailto') {
+          return 1 if (is_email ($1));
+        }
+        elsif ($scheme eq 'strict_mailto') {
+          return 1 if (is_email ($1,1));
+        }

       }
     }
   }
       }
     }
   }


@@ -89,8 +102,11 @@ sub is_URL ($@) {
 #
 # Return: Status code (Bool)
 #
 #
 # Return: Status code (Bool)
 #

-sub is_email ($;$) {
+sub is_email (;$$) {

   my $string = shift;
   my $string = shift;

+  $string = $_ unless defined $string;
+  return unless defined $string;
+

   my $strict = shift;
 
   # false if any non-ascii chars
   my $strict = shift;
 
   # false if any non-ascii chars


@@ -141,7 +157,7 @@ BEGIN {
 
   @email = ();
   for $domain (
 
   @email = ();
   for $domain (

-    qq< $sub_domain (?: $Period $X $sub_domain )+ >,
+    qq< $sub_domain (?: $Period $X $sub_domain )* $Period [A-Za-z][A-Za-z][A-Za-z]?[A-Za-z]? >,

     qq< $sub_domain (?: $Period $X $sub_domain )* >
   ) {
     my $route       = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
     qq< $sub_domain (?: $Period $X $sub_domain )* >
   ) {
     my $route       = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;


@@ -175,22 +191,22 @@ BEGIN {
   # credits to an unknown(?) programmer ;)
   # modified by n.d.p.
 
   # credits to an unknown(?) programmer ;)
   # modified by n.d.p.
 

-  my $lowalpha       =  '(?:[a-z])';
-  my $hialpha        =  '(?:[A-Z])';
-  my $alpha          =  "(?:$lowalpha|$hialpha)";
-  my $digit          =  '(?:\d)';
-  my $safe           =  '(?:[$_.+-])';
-  my $extra          =  '(?:[!*\'(),])';
-  my $national       =  '(?:[{}|\\\\^~\[\]`])';
-  my $punctuation    =  '(?:[<>#%"])';
-  my $reserved       =  '(?:[;/?:@&=])';
-  my $hex            =  '(?:[\dA-Fa-f])';
+  my $lowalpha       =  '[a-z]';
+  my $hialpha        =  '[A-Z]';
+  my $alpha          =  '[a-zA-Z]';
+  my $digit          =  '\d';
+  my $safe           =  '[$_.+-]';
+  my $extra          =  '[!*\'(),]';
+  my $national       =  '[{}|\\\\^~\[\]`]';
+  my $punctuation    =  '[<>#%"]';
+  my $reserved       =  '[;/?:@&=]';
+  my $hex            =  '[\dA-Fa-f]';

   my $escape         =  "(?:%$hex$hex)";
   my $escape         =  "(?:%$hex$hex)";

-  my $unreserved     =  "(?:$alpha|$digit|$safe|$extra)";
+  my $unreserved     =  '[{}|\\\\^~\[\]`a-zA-Z\d$_.+-]';    #"(?:$alpha|$digit|$safe|$extra)";

   my $uchar          =  "(?:$unreserved|$escape)";
   my $xchar          =  "(?:$unreserved|$escape|$reserved)";
   my $digits         =  '(?:\d+)';
   my $uchar          =  "(?:$unreserved|$escape)";
   my $xchar          =  "(?:$unreserved|$escape|$reserved)";
   my $digits         =  '(?:\d+)';

-  my $alphadigit     =  "(?:$alpha|\\d)";
+  my $alphadigit     =  '[a-zA-Z\d]';                       #"(?:$alpha|$digit)";

 
   # URL schemeparts for ip based protocols:
   my $urlpath        =  "(?:$xchar*)";
 
   # URL schemeparts for ip based protocols:
   my $urlpath        =  "(?:$xchar*)";


@@ -226,8 +242,8 @@ BEGIN {
   my $hsegment       =  "(?:(?:$httpuchar|[;:\@&=~])*)";
   my $search         =  "(?:(?:$httpuchar|[;:\@&=~])*)";
   my $hpath          =  "(?:$hsegment(?:/$hsegment)*)";
   my $hsegment       =  "(?:(?:$httpuchar|[;:\@&=~])*)";
   my $search         =  "(?:(?:$httpuchar|[;:\@&=~])*)";
   my $hpath          =  "(?:$hsegment(?:/$hsegment)*)";

-  my $httpurl        =  "(?:http://$hostport(?:/$hpath(?:\\?$search)?)?(?:#$xchar*)?)";
-  my $strict_httpurl =  "(?:http://$hostport(?:/$hpath(?:\\?$search)?)?)";
+  my $httpurl        =  "(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?(?:#$xchar*)?)";
+  my $strict_httpurl =  "(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?)";

 
   # GOPHER (see also RFC1436)
   my $gopher_plus    =  "(?:$xchar*)";
 
   # GOPHER (see also RFC1436)
   my $gopher_plus    =  "(?:$xchar*)";


@@ -298,7 +314,7 @@ BEGIN {
   }
 }
 
   }
 }
 

-# keeping require happy
+# keep 'require' happy

 1;
 
 #
 1;
 
 #