selfforum-cgi/shared/CheckRFC.pm

   1 package CheckRFC;
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        shared/CheckRFC.pm                                              #
   6 #                                                                              #
   7 # Authors:     Andre Malo       <nd@o3media.de>, 2001-04-14                    #
   8 #                                                                              #
   9 # Description: implement several string checks on RFC correctness              #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use vars qw(
  15   $v56
  16   %url
  17   @email
  18   @EXPORT
  19   @ISA
  20 );
  21
  22 $v56 = eval q[
  23   local $SIG{__DIE__};
  24   require 5.6.0;
  25 ];
  26
  27 use Carp qw(croak);
  28
  29 ################################################################################
  30 #
  31 # Export
  32 #
  33 require Exporter;
  34 @ISA = qw(Exporter);
  35
  36 @EXPORT = qw(
  37   is_URL
  38   is_email
  39 );
  40
  41 ### is_URL ($@) ################################################################
  42 #
  43 # check URL
  44 #
  45 # Params: $string  string to check
  46 #         @schemes possible URL schemes in $string
  47 #                  qw( http strict_http ftp news nntp telnet
  48 #                      gopher wais mailto strict_mailto file prospero)
  49 #                  if there's no scheme given, 'http' is default
  50 #                  use ':ALL' (without quotes) for all schemes
  51 #
  52 # Return: Status code (Bool)
  53 #
  54 sub is_URL ($@) {
  55   my ($string, @schemes) = @_;
  56
  57   return unless (defined ($string) and length ($string));
  58
  59   @schemes = qw(http) unless (@schemes);
  60   @schemes = keys %url if (@schemes == 1 and $schemes[0] eq ':ALL');
  61
  62   for (@schemes) {
  63     croak "unknown url scheme '$_'" unless exists $url{$_};
  64     unless (/mailto/) {
  65       return 1 if ($string =~ /$url{$_}/);
  66     }
  67     else {
  68       return unless ($string =~ /^mailto:(.+)/);
  69
  70       if ($_ eq 'mailto') {
  71         return 1 if (is_email ($1));
  72       }
  73       elsif ($_ eq 'strict_mailto') {
  74         return 1 if (is_email ($1,1));
  75       }
  76     }
  77   }
  78
  79   # no match => return false
  80   return;
  81 }
  82
  83 ### is_email ($) ###############################################################
  84 #
  85 # check email (comments can be nested)
  86 #
  87 # Params: $string - string to check
  88 #         $strict - (optional) check strict RFC syntax (no TLD needed) if true
  89 #
  90 # Return: Status code (Bool)
  91 #
  92 sub is_email ($;$) {
  93   my $string = shift;
  94   my $strict = shift;
  95
  96   # false if any non-ascii chars
  97   return unless (defined ($string) and length ($string));
  98   return if $string =~ /[\200-\377]/;
  99
 100   # remove nested comments
 101   1 while ($string =~ s/\([^()]*\)//g);
 102   #$string =~ s/^\s+//;
 103   #$string =~ s/\s+$//;
 104
 105   return ($string =~ /^$email[0]$/) unless $strict;
 106
 107   return ($string =~ /^$email[1]$/);
 108 }
 109
 110 ### BEGIN # (1) ################################################################
 111 #
 112 # define regex for nearly RFC 822 email address
 113 #
 114 BEGIN {
 115   # Thanx to J. Friedl:
 116
 117   my $esc         = '\\\\';
 118   my $Period      = '\.';
 119   my $space       = '\040';
 120   my $tab         = '\t';
 121   my $OpenBR      = '\[';
 122   my $CloseBR     = '\]';
 123   my $OpenParen   = '\(';
 124   my $CloseParen  = '\)';
 125   my $NonASCII    = '\x80-\xff';
 126   my $ctrl        = '\000-\037';
 127   my $CRlist      = '\n\015';
 128   my $qtext       = qq/[^$esc$NonASCII$CRlist\"]/;
 129   my $dtext       = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
 130   my $quoted_pair = qq< $esc [^$NonASCII] >;
 131   my $ctext       = qq< [^$esc$NonASCII$CRlist()] >;
 132   my $Cnested     = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >;
 133   my $comment     = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >;
 134   my $X           = qq< [$space$tab]* (?: $comment [$space$tab]* )* >;
 135   my $atom_char   = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
 136   my $atom        = qq< $atom_char+ (?!$atom_char) >;
 137   my $quoted_str  = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >;
 138   my $word        = qq< (?: $atom | $quoted_str ) >;
 139   my $domain_ref  = $atom;
 140   my $domain_lit  = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >;
 141   my $sub_domain  = qq< (?: $domain_ref | $domain_lit ) $X >;
 142   my $domain;
 143
 144   @email = ();
 145   for $domain (
 146     qq< $sub_domain (?: $Period $X $sub_domain )* $Period [A-Za-z][A-Za-z][A-Za-z]?[A-Za-z]? >,
 147     qq< $sub_domain (?: $Period $X $sub_domain )* >
 148   ) {
 149     my $route       = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >;
 150     my $local_part  = qq< $word $X (?: $Period $X $word $X )* >;
 151     my $addr_spec   = qq< $local_part \@ $X $domain >;
 152     my $route_addr  = qq[ < $X (?: $route )? $addr_spec > ];
 153     my $phrase_ctrl = '\000-\010\012-\037';
 154     my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
 155     my $phrase      = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >;
 156     my $email       = qq< $X (?: $addr_spec | $phrase  $route_addr ) >;
 157
 158     if ($v56) {
 159       eval q<
 160         local $SIG{__DIE__};
 161         $email = qr/$email/x;
 162       >;
 163     }
 164     else {
 165       $email =~ s/\s+//g;
 166     }
 167
 168     push @email => $email;
 169   }
 170 }
 171
 172 ### BEGIN # (2) ################################################################
 173 #
 174 # define regexes for URLs
 175 #
 176 BEGIN {
 177   # credits to an unknown(?) programmer ;)
 178   # modified by n.d.p.
 179
 180   my $lowalpha       =  '(?:[a-z])';
 181   my $hialpha        =  '(?:[A-Z])';
 182   my $alpha          =  "(?:$lowalpha|$hialpha)";
 183   my $digit          =  '(?:\d)';
 184   my $safe           =  '(?:[$_.+-])';
 185   my $extra          =  '(?:[!*\'(),])';
 186   my $national       =  '(?:[{}|\\\\^~\[\]`])';
 187   my $punctuation    =  '(?:[<>#%"])';
 188   my $reserved       =  '(?:[;/?:@&=])';
 189   my $hex            =  '(?:[\dA-Fa-f])';
 190   my $escape         =  "(?:%$hex$hex)";
 191   my $unreserved     =  "(?:$alpha|$digit|$safe|$extra)";
 192   my $uchar          =  "(?:$unreserved|$escape)";
 193   my $xchar          =  "(?:$unreserved|$escape|$reserved)";
 194   my $digits         =  '(?:\d+)';
 195   my $alphadigit     =  "(?:$alpha|\\d)";
 196
 197   # URL schemeparts for ip based protocols:
 198   my $urlpath        =  "(?:$xchar*)";
 199   my $user           =  "(?:(?:$uchar|[;?&=])*)";
 200   my $password       =  "(?:(?:$uchar|[;?&=])*)";
 201   my $port           =  '(?:[0-5]?\d\d?\d?\d?|6[0-4]\d\d\d|65[0-4]\d\d|655[0-2]\d|6553[0-5])';
 202   my $ip4part        =  '(?:[01]?\d\d?|2[0-4]\d|25[0-5])';
 203   my $hostnumber     =  '(?:(?!0+\.0+\.0+\.0+)(?!255\.255\.255\.255)'."$ip4part\\.$ip4part\\.$ip4part\\.$ip4part)";
 204   my $toplabel       =  "(?:(?:$alpha(?:$alphadigit|-)*$alphadigit)|$alpha)";
 205   my $domainlabel    =  "(?:(?:$alphadigit(?:$alphadigit|-)*$alphadigit)|$alphadigit)";
 206   my $hostname       =  "(?:(?:$domainlabel\\.)*$toplabel)";
 207   my $host           =  "(?:(?:$hostname)|(?:$hostnumber))";
 208   my $hostport       =  "(?:(?:$host)(?::$port)?)";
 209   my $login          =  "(?:(?:$user(?::$password)?\@)?$hostport)";
 210   my $ip_schemepart  =  "(?://$login(?:/$urlpath)?)";
 211
 212   my $schemepart     =  "(?:$xchar*|$ip_schemepart)";
 213   my $scheme         =  "(?:(?:$lowalpha|$digit|[+.-])+)";
 214
 215   # The predefined schemes:
 216
 217   # FTP (see also RFC959)
 218   my $fsegment       =  "(?:(?:$uchar|[?:\@&=])*)";
 219   my $ftptype        =  "(?:[AIDaid])";
 220   my $fpath          =  "(?:$fsegment(?:/$fsegment)*)";
 221   my $ftpurl         =  "(?:ftp://$login(?:/$fpath(?:;type=$ftptype)?)?)";
 222
 223   # FILE
 224   my $fileurl        =  "(?:file://(?:(?:$host)|localhost)?/$fpath)";
 225
 226   # HTTP
 227   my $httpuchar      =  "(?:(?:$alpha|$digit|$safe|(?:[!*\',]))|$escape)";
 228   my $hsegment       =  "(?:(?:$httpuchar|[;:\@&=~])*)";
 229   my $search         =  "(?:(?:$httpuchar|[;:\@&=~])*)";
 230   my $hpath          =  "(?:$hsegment(?:/$hsegment)*)";
 231   my $httpurl        =  "(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?(?:#$xchar*)?)";
 232   my $strict_httpurl =  "(?:https?://$hostport(?:/$hpath(?:\\?$search)?)?)";
 233
 234   # GOPHER (see also RFC1436)
 235   my $gopher_plus    =  "(?:$xchar*)";
 236   my $selector       =  "(?:$xchar*)";
 237   my $gtype          =  "(?:$xchar)";
 238   my $gopherurl      =  "(?:gopher://$hostport(?:/$gtype(?:$selector(?:%09$search(?:%09$gopher_plus)?)?)?)?)";
 239
 240   # NEWS (see also RFC1036)
 241   my $article        =  "(?:(?:$uchar|[;/?:&=])+\@$host)";
 242   my $group          =  "(?:$alpha(?:$alpha|$digit|[.+_-])*)";
 243   my $grouppart      =  "(?:$article|$group|\\*)";
 244   my $newsurl        =  "(?:news:$grouppart)";
 245
 246   # NNTP (see also RFC977)
 247   my $nntpurl        =  "(?:nntp://$hostport/$group(?:/$digits)?)";
 248
 249   # TELNET
 250   my $telneturl      =  "(?:telnet://$login(?:/)?)";
 251
 252   # WAIS (see also RFC1625)
 253   my $wpath          =  "(?:$uchar*)";
 254   my $wtype          =  "(?:$uchar*)";
 255   my $database       =  "(?:$uchar*)";
 256   my $waisdoc        =  "(?:wais://$hostport/$database/$wtype/$wpath)";
 257   my $waisindex      =  "(?:wais://$hostport/$database\\?$search)";
 258   my $waisdatabase   =  "(?:wais://$hostport/$database)";
 259   my $waisurl        =  "(?:$waisdatabase|$waisindex|$waisdoc)";
 260
 261   # PROSPERO
 262   my $fieldvalue     =  "(?:(?:$uchar|[?:\@&]))";
 263   my $fieldname      =  "(?:(?:$uchar|[?:\@&]))";
 264   my $fieldspec      =  "(?:;$fieldname=$fieldvalue)";
 265   my $psegment       =  "(?:(?:$uchar|[?:\@&=]))";
 266   my $ppath          =  "(?:$psegment(?:/$psegment)*)";
 267   my $prosperourl    =  "(?:prospero://$hostport/$ppath(?:$fieldspec)*)";
 268
 269   if ($v56) {
 270     eval q[%url = (
 271       http          => qr/^$httpurl$/,
 272       strict_http   => qr/^$strict_httpurl$/,
 273       ftp           => qr/^$ftpurl$/,
 274       news          => qr/^$newsurl$/,
 275       nntp          => qr/^$nntpurl$/,
 276       telnet        => qr/^$telneturl$/,
 277       gopher        => qr/^$gopherurl$/,
 278       wais          => qr/^$waisurl$/,
 279       mailto        => 0,
 280       strict_mailto => 0,
 281       file          => qr/^$fileurl$/,
 282       prospero      => qr/^$prosperourl$/
 283     );];
 284   }
 285   else {
 286     %url = (
 287       http          => "^$httpurl\$",
 288       strict_http   => "^$strict_httpurl\$",
 289       ftp           => "^$ftpurl\$",
 290       news          => "^$newsurl\$",
 291       nntp          => "^$nntpurl\$",
 292       telnet        => "^$telneturl\$",
 293       gopher        => "^$gopherurl\$",
 294       wais          => "^$waisurl\$",
 295       mailto        => 0,
 296       strict_mailto => 0,
 297       file          => "^$fileurl\$",
 298       prospero      => "^$prosperourl\$"
 299     );
 300   }
 301 }
 302
 303 # keeping require happy
 304 1;
 305
 306 #
 307 #
 308 ### end of CheckRFC ############################################################