X-Git-Url: https://git.p6c8.net/selfforum.git/blobdiff_plain/489e7846289d4fb66eb4b9fab0fed4af719b98ee..e0e1833d60647df91b471bff59ba257fa202eb36:/selfforum-cgi/shared/CheckRFC.pm?ds=inline diff --git a/selfforum-cgi/shared/CheckRFC.pm b/selfforum-cgi/shared/CheckRFC.pm index ddde67f..b000dcf 100644 --- a/selfforum-cgi/shared/CheckRFC.pm +++ b/selfforum-cgi/shared/CheckRFC.pm @@ -17,6 +17,7 @@ use vars qw( @email @EXPORT @ISA + $VERSION ); $v56 = eval q[ @@ -26,6 +27,10 @@ $v56 = eval q[ use Carp qw(croak); +# Version check +# +$VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + ################################################################################ # # Export @@ -51,27 +56,30 @@ require Exporter; # # Return: Status code (Bool) # -sub is_URL ($@) { +sub is_URL (;$@) { 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'); - 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 { - 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 +97,11 @@ sub is_URL ($@) { # # Return: Status code (Bool) # -sub is_email ($;$) { +sub is_email (;$$) { my $string = shift; + $string = $_ unless defined $string; + return unless defined $string; + my $strict = shift; # false if any non-ascii chars @@ -141,7 +152,7 @@ BEGIN { @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 >; @@ -175,22 +186,22 @@ 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 $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 $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 $alphadigit = "(?:$alpha|\\d)"; + my $alphadigit = '[a-zA-Z\d]'; #"(?:$alpha|$digit)"; # URL schemeparts for ip based protocols: my $urlpath = "(?:$xchar*)"; @@ -226,8 +237,8 @@ BEGIN { 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*)";