From: ndparker <> Date: Fri, 30 Mar 2001 04:17:01 +0000 (+0000) Subject: added CheckRFC.pm X-Git-Url: https://git.p6c8.net/selfforum.git/commitdiff_plain/944a9d6fad0266526530c0e27aa7474a80eb8ede added CheckRFC.pm replaced 'die' by Carp::croak in Template.pm no real changes in fo_view.pl ;) --- diff --git a/selfforum-cgi/shared/CheckRFC.pm b/selfforum-cgi/shared/CheckRFC.pm new file mode 100644 index 0000000..6c64ade --- /dev/null +++ b/selfforum-cgi/shared/CheckRFC.pm @@ -0,0 +1,235 @@ +package CheckRFC; + +################################################################################ +# # +# File: shared/CheckRFC.pm # +# # +# Authors: Andre Malo , 2001-03-30 # +# # +# Description: implement several string checks on RFC correctness # +# # +################################################################################ + +use strict; + +use vars qw(%url $email @EXPORT); + +use autouse 'Carp' => 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 => 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< $esc [^$NonASCII] >; + my $ctext = qq< [^$esc$NonASCII$CRlist()] >; + my $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >; + my $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >; + my $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >; + my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/; + my $atom = qq< $atom_char+ (?!$atom_char) >; + my $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >; + my $word = qq< (?: $atom | $quoted_str ) >; + my $domain_ref = $atom; + my $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >; + my $sub_domain = qq< (?: $domain_ref | $domain_lit ) $X >; + my $domain = qq< $sub_domain (?: $Period $X $sub_domain )* >; + my $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >; + my $local_part = qq< $word $X (?: $Period $X $word $X )* >; + my $addr_spec = qq< $local_part \@ $X $domain >; + my $route_addr = qq[ < $X (?: $route )? $addr_spec > ]; + my $phrase_ctrl = '\000-\010\012-\037'; + my $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/; + my $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >; + $email = qq< $X (?: $addr_spec | $phrase $route_addr ) >; + $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 = '(?:[<>#%"])'; + my $reserved = '(?:[;/?:@&=])'; + 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|[;?&=])*)"; + my $password = "(?:(?:$uchar|[;?&=])*)"; + 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|[?:\@&=])*)"; + 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|[;:\@&=~])*)"; + my $search = "(?:(?:$httpuchar|[;:\@&=~])*)"; + my $hpath = "(?:$hsegment(?:/$hsegment)*)"; + my $httpurl = "(?:http://$hostport(?:/$hpath(?:\\?$search)?)?)"; + + # 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|[;/?:&=])+\@$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|[?:\@&]))"; + my $fieldname = "(?:(?:$uchar|[?:\@&]))"; + my $fieldspec = "(?:;$fieldname=$fieldvalue)"; + my $psegment = "(?:(?:$uchar|[?:\@&=]))"; + my $ppath = "(?:$psegment(?:/$psegment)*)"; + my $prosperourl = "(?:prospero://$hostport/$ppath(?:$fieldspec)*)"; + + %url = ( + http => qr/^$httpurl$/, + ftp => qr/^$ftpurl$/, + news => qr/^$newsurl$/, + nntp => qr/^$nntpurl$/, + telnet => qr/^$telneturl$/, + gopher => qr/^$gopherurl$/, + wais => qr/^$waisurl$/, + mailto => qr/^$mailtourl$/, + file => qr/^$fileurl$/, + prospero => qr/^$prosperourl$/ + ); +} + +# keeping require happy +1; + +# +# +### end of CheckRFC ############################################################ \ No newline at end of file diff --git a/selfforum-cgi/shared/Mail.pm b/selfforum-cgi/shared/Mail.pm index 8ba56e3..8070704 100644 --- a/selfforum-cgi/shared/Mail.pm +++ b/selfforum-cgi/shared/Mail.pm @@ -20,6 +20,8 @@ package Mail; use vars qw($mailbox $mailprog @EXPORT); +use autouse 'CheckRFC' => qw(is_email($)); + # =================== # Funktionsexport # =================== @@ -40,7 +42,7 @@ use base qw(Exporter); ######################################## sub is_mail_address ($) { - return ($_[0] =~ /$mailbox/); + return is_email $_[0]; } ######################################## @@ -235,51 +237,9 @@ BEGIN { # =================================================================== $mailprog = '|/usr/lib/sendmail -t -oi'; - - # Thanx to J. Friedl for this regex: - - my ($address,$route_addr,$phrase,$addr_spec,$X,$phrase_char,$quoted_str,$comment,$word,$phrase_ctrl,$NonASCII, - $CloseBR,$OpenBR,$esc,$route,$domain,$local_part,$Period,$sub_domain,$domain_lit,$domain_ref,$quoted_pair, - $dtext,$atom,$qtext,$atom_char,$ctrl,$space,$tab,$CloseParen,$ctext,$Cnested,$OpenParen,$CRlist); - - $esc = '\\\\'; - $Period = '\.'; - $space = '\040'; - $tab = '\t'; - $OpenBR = '\['; - $CloseBR = '\]'; - $OpenParen = '\('; - $CloseParen = '\)'; - $NonASCII = '\x80-\xff'; - $ctrl = '\000-\037'; - $CRlist = '\n\015'; - $qtext = qq/[^$esc$NonASCII$CRlist\"]/; - $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/; - $quoted_pair = qq< $esc [^$NonASCII] >; - $ctext = qq< [^$esc$NonASCII$CRlist()] >; - $Cnested = qq< $OpenParen $ctext* (?: $quoted_pair $ctext* )* $CloseParen >; - $comment = qq< $OpenParen $ctext* (?: (?: $quoted_pair | $Cnested ) $ctext* )* $CloseParen >; - $X = qq< [$space$tab]* (?: $comment [$space$tab]* )* >; - $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/; - $atom = qq< $atom_char+ (?!$atom_char) >; - $quoted_str = qq< \" $qtext * (?: $quoted_pair $qtext * )* \" >; - $word = qq< (?: $atom | $quoted_str ) >; - $domain_ref = $atom; - $domain_lit = qq< $OpenBR (?: $dtext | $quoted_pair )* $CloseBR >; - $sub_domain = qq< (?: $domain_ref | $domain_lit ) $X >; - $domain = qq< $sub_domain (?: $Period $X $sub_domain )* >; - $route = qq< \@ $X $domain (?: , $X \@ $X $domain )* : $X >; - $local_part = qq< $word $X (?: $Period $X $word $X )* >; - $addr_spec = qq< $local_part \@ $X $domain >; - $route_addr = qq[ < $X (?: $route )? $addr_spec > ]; - $phrase_ctrl = '\000-\010\012-\037'; - $phrase_char = qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/; - $phrase = qq< $word $phrase_char * (?: (?: $comment | $quoted_str ) $phrase_char * )* >; - $mailbox = qq< $X (?: $addr_spec | $phrase $route_addr ) >; - $mailbox = qr ~^$mailbox$~x; } -# making 'require' happy +# keeping require happy 1; ##################### diff --git a/selfforum-cgi/shared/Template.pm b/selfforum-cgi/shared/Template.pm index d029493..a55f79e 100644 --- a/selfforum-cgi/shared/Template.pm +++ b/selfforum-cgi/shared/Template.pm @@ -12,7 +12,7 @@ use strict; package Template; -use CGI::Carp qw(croak); +use autouse 'Carp' => qw(croak); use XML::DOM; # ==================================================== diff --git a/selfforum-cgi/user/fo_view.pl b/selfforum-cgi/user/fo_view.pl index 0aefde4..fb2ab8c 100644 --- a/selfforum-cgi/user/fo_view.pl +++ b/selfforum-cgi/user/fo_view.pl @@ -16,8 +16,8 @@ use CGI::Carp qw(fatalsToBrowser); use Conf; use Conf::Admin; -use Template::Forum; -use Template::Posting; +use autouse 'Template::Forum' => qw(print_forum_as_HTML($$$)); +use autouse 'Template::Posting' => qw(print_posting_as_HTML($$$)); use CGI qw(param header); @@ -25,8 +25,6 @@ print header(-type => 'text/html'); my $conf = read_script_conf ($Bin, $Shared, $Script); -#$conf -> {wwwRoot} = 'i:/i_selfhtml/htdocs' unless ($ENV{GATEWAY_INTERFACE} =~ /CGI/); - my $show = $conf -> {show}; my $show_forum = $show -> {Forum}; my $show_posting = $show -> {Posting};