<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package CheckRFC;

################################################################################
#                                                                              #
# File:        shared/CheckRFC.pm                                              #
#                                                                              #
# Authors:     Andre Malo       &lt;nd@o3media.de&gt;, 2001-03-30                    #
#                                                                              #
# Description: implement several string checks on RFC correctness              #
#                                                                              #
################################################################################

use strict;
use vars qw(%url $email @EXPORT);

use autouse 'Carp' =&gt; qw(croak);

################################################################################
#
# Export
#
use base qw(Exporter);
@EXPORT = qw(is_URL is_email);

### is_URL ($@) ################################################################
#
# check URL
#
# Params: $string  string to check
#         @schemes possible URL schemes in $string
#                  qw(http ftp news nntp telnet gopher wais mailto file prospero)
#                  if there's no scheme given, 'http' is default
#                  use ':ALL' (without quotes) for all schemes
#
# Return: Status code (Bool)
#
sub is_URL ($@) {
  my ($string, @schemes) = @_;
  @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{$_};
    return 1 if $string =~ /$url{$_}/;
  }

  # no match =&gt; return false
  return;
}

### is_email ($) ###############################################################
#
# check email (comments can be nested)
#
# Params: $string string to check
#
# Return: Status code (Bool)
#
sub is_email ($) {
  my $string = shift;

  # false if any non-ascii chars
  return if $string =~ /[\200-\377]/;

  # remove nested comments
  while ($string =~ s/\([^()]*\)//g) {};

  return ($string =~ /^$email$/);
}

### BEGIN # (1) ################################################################
#
# define regex for nearly RFC 822 email address
#
BEGIN {
  # Thanx to J. Friedl:

  my $esc        = '\\\\';
  my $Period      = '\.';
  my $space      = '\040';
  my $tab         = '\t';
  my $OpenBR     = '\[';
  my $CloseBR     = '\]';
  my $OpenParen  = '\(';
  my $CloseParen  = '\)';
  my $NonASCII   = '\x80-\xff';
  my $ctrl        = '\000-\037';
  my $CRlist     = '\n\015';
  my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;
  my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
  my $quoted_pair = qq&lt; $esc [^$NonASCII] &gt;;
  my $ctext   = qq&lt; [^$esc$NonASCII$CRlist()] &gt;;
  my $Cnested = qq&lt; $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen &gt;;
  my $comment = qq&lt; $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen &gt;;
  my $X = qq&lt; [$space$tab]* (?: $comment [$space$tab]* )* &gt;;
  my $atom_char   = qq/[^($space)&lt;&gt;\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
  my $atom = qq&lt; $atom_char+ (?!$atom_char) &gt;;
  my $quoted_str = qq&lt; \" $qtext * (?: $quoted_pair $qtext * )* \" &gt;;
  my $word = qq&lt; (?: $atom | $quoted_str ) &gt;;
  my $domain_ref  = $atom;
  my $domain_lit  = qq&lt; $OpenBR (?: $dtext | $quoted_pair )* $CloseBR &gt;;
  my $sub_domain  = qq&lt; (?: $domain_ref | $domain_lit ) $X &gt;;
  my $domain = qq&lt; $sub_domain (?: $Period $X $sub_domain )* &gt;;
  my $route = qq&lt; \@ $X $domain (?: , $X \@ $X $domain )* : $X &gt;;
  my $local_part = qq&lt; $word $X (?: $Period $X $word $X )* &gt;;
  my $addr_spec  = qq&lt; $local_part \@ $X $domain &gt;;
  my $route_addr = qq[ &lt; $X (?: $route )? $addr_spec &gt; ];
  my $phrase_ctrl = '\000-\010\012-\037';
  my $phrase_char = qq/[^()&lt;&gt;\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
  my $phrase = qq&lt; $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* &gt;;
  $email = qq&lt; $X (?: $addr_spec | $phrase  $route_addr ) &gt;;
  $email = qr /$email/x;
}

### BEGIN # (2) ################################################################
#
# define regexes for URLs
#
BEGIN {
  # 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    =  '(?:[&lt;&gt;#%"])';
  my $reserved       =  '(?:[;/?:@&amp;=])';
  my $hex            =  '(?:[\dA-Fa-f])';
  my $escape         =  "(?:%$hex$hex)";
  my $unreserved     =  "(?:$alpha|$digit|$safe|$extra)";
  my $uchar          =  "(?:$unreserved|$escape)";
  my $xchar          =  "(?:$unreserved|$escape|$reserved)";
  my $digits         =  '(?:\d+)';
  my $alphadigit     =  "(?:$alpha|\\d)";

  # URL schemeparts for ip based protocols:
  my $urlpath        =  "(?:$xchar*)";
  my $user           =  "(?:(?:$uchar|[;?&amp;=])*)";
  my $password       =  "(?:(?:$uchar|[;?&amp;=])*)";
  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])';
  my $ip4part        =  '(?:[01]?\d\d?|2[0-4]\d|25[0-5])';
  my $hostnumber     =  '(?:(?!0+\.0+\.0+\.0+)'."$ip4part\\.$ip4part\\.$ip4part\\.$ip4part)";
  my $toplabel       =  "(?:(?:$alpha(?:$alphadigit|-)*$alphadigit)|$alpha)";
  my $domainlabel    =  "(?:(?:$alphadigit(?:$alphadigit|-)*$alphadigit)|$alphadigit)";
  my $hostname       =  "(?:(?:$domainlabel\\.)*$toplabel)";
  my $host           =  "(?:(?:$hostname)|(?:$hostnumber))";
  my $hostport       =  "(?:(?:$host)(?::$port)?)";
  my $login          =  "(?:(?:$user(?::$password)?\@)?$hostport)";
  my $ip_schemepart  =  "(?://$login(?:/$urlpath)?)";

  my $schemepart     =  "(?:$xchar*|$ip_schemepart)";
  my $scheme         =  "(?:(?:$lowalpha|$digit|[+.-])+)";

  # The predefined schemes:

  # FTP (see also RFC959)
  my $fsegment       =  "(?:(?:$uchar|[?:\@&amp;=])*)";
  my $ftptype        =  "(?:[AIDaid])";
  my $fpath          =  "(?:$fsegment(?:/$fsegment)*)";
  my $ftpurl         =  "(?:ftp://$login(?:/$fpath(?:;type=$ftptype)?)?)";

  # FILE
  my $fileurl        =  "(?:file://(?:(?:$host)|localhost)?/$fpath)";

  # HTTP
  my $httpuchar      =  "(?:(?:$alpha|$digit|$safe|(?:[!*\',]))|$escape)";
  my $hsegment       =  "(?:(?:$httpuchar|[;:\@&amp;=~])*)";
  my $search         =  "(?:(?:$httpuchar|[;:\@&amp;=~])*)";
  my $hpath          =  "(?:$hsegment(?:/$hsegment)*)";
  my $httpurl        =  "(?:http://$hostport(?:/$hpath(?:\\?$search)?)?(?:#$xchar*)?)";

  # GOPHER (see also RFC1436)
  my $gopher_plus    =  "(?:$xchar*)";
  my $selector       =  "(?:$xchar*)";
  my $gtype          =  "(?:$xchar)";
  my $gopherurl      =  "(?:gopher://$hostport(?:/$gtype(?:$selector(?:%09$search(?:%09$gopher_plus)?)?)?)?)";

  # MAILTO (see also RFC822)
  my $encoded822addr =  "(?:$email)";
  my $mailtourl      =  "(?:mailto:$encoded822addr)";

  # NEWS (see also RFC1036)
  my $article        =  "(?:(?:$uchar|[;/?:&amp;=])+\@$host)";
  my $group          =  "(?:$alpha(?:$alpha|$digit|[.+_-])*)";
  my $grouppart      =  "(?:$article|$group|\\*)";
  my $newsurl        =  "(?:news:$grouppart)";

  # NNTP (see also RFC977)
  my $nntpurl        =  "(?:nntp://$hostport/$group(?:/$digits)?)";

  # TELNET
  my $telneturl      =  "(?:telnet://$login(?:/)?)";

  # WAIS (see also RFC1625)
  my $wpath          =  "(?:$uchar*)";
  my $wtype          =  "(?:$uchar*)";
  my $database       =  "(?:$uchar*)";
  my $waisdoc        =  "(?:wais://$hostport/$database/$wtype/$wpath)";
  my $waisindex      =  "(?:wais://$hostport/$database\\?$search)";
  my $waisdatabase   =  "(?:wais://$hostport/$database)";
  my $waisurl        =  "(?:$waisdatabase|$waisindex|$waisdoc)";

  # PROSPERO
  my $fieldvalue     =  "(?:(?:$uchar|[?:\@&amp;]))";
  my $fieldname      =  "(?:(?:$uchar|[?:\@&amp;]))";
  my $fieldspec      =  "(?:;$fieldname=$fieldvalue)";
  my $psegment       =  "(?:(?:$uchar|[?:\@&amp;=]))";
  my $ppath          =  "(?:$psegment(?:/$psegment)*)";
  my $prosperourl    =  "(?:prospero://$hostport/$ppath(?:$fieldspec)*)";

  %url = (
    http     =&gt; qr/^$httpurl$/,
    ftp      =&gt; qr/^$ftpurl$/,
    news     =&gt; qr/^$newsurl$/,
    nntp     =&gt; qr/^$nntpurl$/,
    telnet   =&gt; qr/^$telneturl$/,
    gopher   =&gt; qr/^$gopherurl$/,
    wais     =&gt; qr/^$waisurl$/,
    mailto   =&gt; qr/^$mailtourl$/,
    file     =&gt; qr/^$fileurl$/,
    prospero =&gt; qr/^$prosperourl$/
  );
}

# keeping require happy
1;

#
#
### end of CheckRFC ############################################################</pre></body></html>