Data-Validate-URI-0.06/0000755000076400007640000000000011716003460014064 5ustar sonnensonnenData-Validate-URI-0.06/lib/0000755000076400007640000000000011716003460014632 5ustar sonnensonnenData-Validate-URI-0.06/lib/Data/0000755000076400007640000000000011716003460015503 5ustar sonnensonnenData-Validate-URI-0.06/lib/Data/Validate/0000755000076400007640000000000011716003460017234 5ustar sonnensonnenData-Validate-URI-0.06/lib/Data/Validate/URI.pm0000644000076400007640000003300311716003270020227 0ustar sonnensonnenpackage Data::Validate::URI; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); require Exporter; use AutoLoader 'AUTOLOAD'; use Data::Validate::Domain; use Data::Validate::IP; @ISA = qw(Exporter); # no functions are exported by default. See EXPORT_OK @EXPORT = qw(); @EXPORT_OK = qw( is_uri is_http_uri is_https_uri is_web_uri is_tel_uri ); %EXPORT_TAGS = (); $VERSION = '0.06'; # No preloads 1; __END__ =head1 NAME Data::Validate::URI - common url validation methods =head1 SYNOPSIS use Data::Validate::URI qw(is_uri); if(is_uri($suspect)){ print "Looks like an URI\n"; } else { print "Not a URI\n"; } # or as an object my $v = Data::Validate::URI->new(); die "not a URI" unless ($v->is_uri('foo')); =head1 DESCRIPTION This module collects common URI validation routines to make input validation, and untainting easier and more readable. All functions return an untainted value if the test passes, and undef if it fails. This means that you should always check for a defined status explicitly. Don't assume the return will be true. The value to test is always the first (and often only) argument. There are a number of other URI validation modules out there as well (see below.) This one focuses on being fast, lightweight, and relatively 'real-world'. i.e. it's good if you want to check user input, and don't need to parse out the URI/URL into chunks. Right now the module focuses on HTTP URIs, since they're arguably the most common. If you have a specialized scheme you'd like to have supported, let me know. =head1 FUNCTIONS =cut # ------------------------------------------------------------------------------- =pod =over 4 =item B - constructor for OO usage new(); =over 4 =item I Returns a Data::Validator::URI object. This lets you access all the validator function calls as methods without importing them into your namespace or using the clumsy Data::Validate::URI::function_name() format. =item I None =item I Returns a Data::Validate::URI object =back =cut sub new{ my $class = shift; return bless {}, $class; } # ------------------------------------------------------------------------------- =pod =item B - is the value a well-formed uri? is_uri($value); =over 4 =item I Returns the untainted URI if the test value appears to be well-formed. Note that you may really want one of the more practical methods like is_http_uri or is_https_uri, since the URI standard (RFC 3986) allows a lot of things you probably don't want. =item I =over 4 =item $value The potential URI to test. =back =item I Returns the untainted URI on success, undef on failure. =item I This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. =back =cut sub is_uri{ my $self = shift if ref($_[0]); my $value = shift; return unless defined($value); # check for illegal characters return if $value =~ /[^a-z0-9\:\/\?\#\[\]\@\!\$\&\'\(\)\*\+\,\;\=\.\-\_\~\%]/i; # check for hex escapes that aren't complete return if $value =~ /%[^0-9a-f]/i; return if $value =~ /%[0-9a-f](:?[^0-9a-f]|$)/i; # from RFC 3986 my($scheme, $authority, $path, $query, $fragment) = _split_uri($value); # scheme and path are required, though the path can be empty return unless (defined($scheme) && length($scheme) && defined($path)); # if authority is present, the path must be empty or begin with a / if(defined($authority) && length($authority)){ return unless(length($path) == 0 || $path =~ m!^/!); } else { # if authority is not present, the path must not start with // return if $path =~ m!^//!; } # scheme must begin with a letter, then consist of letters, digits, +, ., or - return unless lc($scheme) =~ m!^[a-z][a-z0-9\+\-\.]*$!; # re-assemble the URL per section 5.3 in RFC 3986 my $out = $scheme . ':'; if(defined $authority && length($authority)){ $out .= '//' . $authority; } $out .= $path; if(defined $query && length($query)){ $out .= '?' . $query; } if(defined $fragment && length($fragment)){ $out .= '#' . $fragment; } return $out; } # ------------------------------------------------------------------------------- =pod =item B - is the value a well-formed HTTP uri? is_http_uri($value); =over 4 =item I Specialized version of is_uri() that only likes http:// urls. As a result, it can also do a much more thorough job validating. Also, unlike is_uri() it is more concerned with only allowing real-world URIs through. Things like relative hostnames are allowed by the standards, but probably aren't wise. Conversely, null paths aren't allowed per RFC 2616 (should be '/' instead), but are allowed by this function. This function only works for fully-qualified URIs. /bob.html won't work. See RFC 3986 for the appropriate method to turn a relative URI into an absolute one given its context. Returns the untainted URI if the test value appears to be well-formed. Note that you probably want to either call this in combo with is_https_uri(). i.e. print "Good" if(is_http_uri($uri) || is_https_uri($uri)); or use the convenience method is_web_uri which is equivalent. =item I =over 4 =item $value The potential URI to test. =back =item I Returns the untainted URI on success, undef on failure. =item I This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. =back =cut sub is_http_uri{ my $self = shift if ref($_[0]); my $value = shift; my $allow_https = shift; return unless is_uri($value); my($scheme, $authority, $path, $query, $fragment) = _split_uri($value); return unless $scheme; if($allow_https){ return unless lc($scheme) eq 'https'; } else { return unless lc($scheme) eq 'http'; } # fully-qualified URIs must have an authority section that is # a valid host return unless($authority); # allow a port component my($port) = $authority =~ /:(\d+)$/; $authority =~ s/:\d+$//; # modifying this to allow the (discouraged, but still legal) use of IP addresses unless(Data::Validate::Domain::is_domain($authority) || Data::Validate::IP::is_ipv4($authority)){ return; } # re-assemble the URL per section 5.3 in RFC 3986 my $out = $scheme . ':'; $out .= '//' . $authority; $out .= ':' . $port if $port; $out .= $path; if(defined $query && length($query)){ $out .= '?' . $query; } if(defined $fragment && length($fragment)){ $out .= '#' . $fragment; } return $out; } # ------------------------------------------------------------------------------- =pod =item B - is the value a well-formed HTTPS uri? is_https_uri($value); =over 4 =item I See is_http_uri() for details. This version only likes the https URI scheme. Otherwise it's identical to is_http_uri() =item I =over 4 =item $value The potential URI to test. =back =item I Returns the untainted URI on success, undef on failure. =item I This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. =back =cut sub is_https_uri{ my $self = shift if ref($_[0]); my $value = shift; return is_http_uri($value, 1); } # ------------------------------------------------------------------------------- =pod =item B - is the value a well-formed HTTP or HTTPS uri? is_web_uri($value); =over 4 =item I This is just a convinience method that combines is_http_uri and is_https_uri to accept most common real-world URLs. =item I =over 4 =item $value The potential URI to test. =back =item I Returns the untainted URI on success, undef on failure. =item I This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. =back =cut sub is_web_uri{ my $self = shift if ref($_[0]); my $value = shift; my $h = is_http_uri($value); return $h if defined $h; return is_https_uri($value); } # ------------------------------------------------------------------------------- =pod =item B - is the value a well-formed telephone uri? is_tel_uri($value); =over 4 =item I Specialized version of is_uri() that only likes tel: urls. As a result, it can also do a much more thorough job validating according to RFC 3966. Returns the untainted URI if the test value appears to be well-formed. =item I =over 4 =item $value The potential URI to test. =back =item I Returns the untainted URI on success, undef on failure. =item I This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. =back =cut sub is_tel_uri{ my $self = shift if ref($_[0]); my $value = shift; # extracted from http://tools.ietf.org/html/rfc3966#section-3 my $hex_digit = '[a-fA-F0-9]'; # strictly hex digit does not allow lower case letters according to http://tools.ietf.org/html/rfc2234#section-6.1 my $reserved = '[;/?:@&=+$,]'; my $alphanum = '[A-Za-z0-9]'; my $visual_separator = '[\-\.\(\)]'; my $phonedigit_hex = '(?:' . $hex_digit . '|\*|\#|' . $visual_separator . ')'; my $phonedigit = '(?:' . '\d' . '|' . $visual_separator . ')'; my $param_unreserved = '[\[\]\/:&+$]'; my $pct_encoded = '\\%' . $hex_digit . $hex_digit; my $mark = "[\-_\.!~*'()]"; my $unreserved = '(?:' . $alphanum . '|' . $mark . ')'; my $paramchar = '(?:' . $param_unreserved . '|' . $unreserved . '|' . $pct_encoded . ')'; my $pvalue = $paramchar . '{1,}'; my $pname = '(?:' . $alphanum . '|\\-){1,}'; my $uric = '(?:' . $reserved . '|' . $unreserved . '|' . $pct_encoded . ')'; my $alpha = '[A-Za-z]'; my $toplabel = '(?:' . $alpha . '|' . $alpha . '(?:' . $alphanum . '|' . '\\-){0,}' . $alpha . ')'; my $domainlabel = '(?:' . $alphanum . '|' . $alphanum . '(?:' . $alphanum . '|\\-){0,}' . $alphanum . ')'; my $domainname = '(?:' . $domainlabel . '\\.){0,}' . $toplabel . '\\.{0,1}'; # extracted from http://tools.ietf.org/html/rfc4694#section-4 my $npdi = ';npdi'; my $hex_phonedigit = '(?:' . $hex_digit . '|' . $visual_separator . ')'; my $global_hex_digits = '\\+' . '\\d{1,3}' . $hex_phonedigit . '{0,}'; my $global_rn = $global_hex_digits; my $rn_descriptor = '(?:' . $domainname . '|' . $global_hex_digits . ')'; my $rn_context = ';rn-context=' . $rn_descriptor; my $local_rn = $hex_phonedigit . '{1,}' . $rn_context; my $global_cic = $global_hex_digits; my $cic_context = ';cic-context=' . $rn_descriptor; my $local_cic = $hex_phonedigit . '{1,}' . $cic_context; my $cic = ';cic=' . '(?:' . $global_cic . '|' . $local_cic . '){0,1}'; my $rn = ';rn=' . '(?:' . $global_rn . '|' . $local_rn . '){0,1}'; if ($value =~ /$rn.*$rn/xsm) { return; } if ($value =~ /$npdi.*$npdi/xsm) { return; } if ($value =~ /$cic.*$cic/xsm) { return; } my $parameter = '(?:;' . $pname . '(?:=' . $pvalue . ')|' . $rn . '|' . $cic . '|' . $npdi . ')'; # end of http://tools.ietf.org/html/rfc4694#section-4 my $local_number_digits = '(?:' . $phonedigit_hex . '{0,}' . '(?:' . $hex_digit . '|\*|\#)' . $phonedigit_hex . '{0,})'; my $global_number_digits = '\+' . $phonedigit . '{0,}' . '[0-9]' . $phonedigit . '{0,}'; my $descriptor = '(?:' . $domainname . '|' . $global_number_digits . ')'; my $context = ';phone\-context=' . $descriptor; my $extension = ';ext=' . $phonedigit . '{1,}'; my $isdn_subaddress = ';isub=' . $uric . '{1,}'; # extracted from http://tools.ietf.org/html/rfc4759 my $enum_dip_indicator = ';enumdi'; if ($value =~ /$enum_dip_indicator.*$enum_dip_indicator/xsm) { # http://tools.ietf.org/html/rfc4759#section-3 return; } # extracted from http://tools.ietf.org/html/rfc4904#section-5 my $trunk_group_unreserved = '[/&+$]'; my $escaped = '\\%' . $hex_digit . $hex_digit; # according to http://tools.ietf.org/html/rfc3261#section-25.1 my $trunk_group_label = '(?:' . $unreserved . '|' . $escaped . '|' . $trunk_group_unreserved . '){1,}'; my $trunk_group = ';tgrp=' . $trunk_group_label; my $trunk_context = ';trunk\-context=' . $descriptor; my $par = '(?:' . $parameter . '|' . $extension . '|' . $isdn_subaddress . '|' . $enum_dip_indicator . '|' . $trunk_context . '|' . $trunk_group . ')'; my $local_number = $local_number_digits . $par . '{0,}' . $context . $par . '{0,}'; my $global_number = $global_number_digits . $par . '{0,}'; my $telephone_subscriber = '(?:' . $global_number . '|' . $local_number . ')'; my $telephone_uri = 'tel:' . $telephone_subscriber; if ($value =~ /^($telephone_uri)$/xsm) { my ($untainted) = ($1); return $untainted; } else { return; } } # internal URI spitter method - direct from RFC 3986 sub _split_uri{ my $value = shift; my @bits = $value =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; return @bits; } =pod =back =head1 SEE ALSO L, RFC 3986, RFC 3966, RFC 4694, RFC 4759, RFC 4904 =head1 AUTHOR Richard Sonnen >. is_tel_uri by David Dick >. =head1 COPYRIGHT Copyright (c) 2005 Richard Sonnen. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Data-Validate-URI-0.06/README0000644000076400007640000001464511716003336014760 0ustar sonnensonnenNAME Data::Validate::URI - common url validation methods SYNOPSIS use Data::Validate::URI qw(is_uri); if(is_uri($suspect)){ print "Looks like an URI\n"; } else { print "Not a URI\n"; } # or as an object my $v = Data::Validate::URI->new(); die "not a URI" unless ($v->is_uri('foo')); DESCRIPTION This module collects common URI validation routines to make input validation, and untainting easier and more readable. All functions return an untainted value if the test passes, and undef if it fails. This means that you should always check for a defined status explicitly. Don't assume the return will be true. The value to test is always the first (and often only) argument. There are a number of other URI validation modules out there as well (see below.) This one focuses on being fast, lightweight, and relatively 'real-world'. i.e. it's good if you want to check user input, and don't need to parse out the URI/URL into chunks. Right now the module focuses on HTTP URIs, since they're arguably the most common. If you have a specialized scheme you'd like to have supported, let me know. FUNCTIONS new - constructor for OO usage new(); *Description* Returns a Data::Validator::URI object. This lets you access all the validator function calls as methods without importing them into your namespace or using the clumsy Data::Validate::URI::function_name() format. *Arguments* None *Returns* Returns a Data::Validate::URI object is_uri - is the value a well-formed uri? is_uri($value); *Description* Returns the untainted URI if the test value appears to be well-formed. Note that you may really want one of the more practical methods like is_http_uri or is_https_uri, since the URI standard (RFC 3986) allows a lot of things you probably don't want. *Arguments* $value The potential URI to test. *Returns* Returns the untainted URI on success, undef on failure. *Notes, Exceptions, & Bugs* This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. is_http_uri - is the value a well-formed HTTP uri? is_http_uri($value); *Description* Specialized version of is_uri() that only likes http:// urls. As a result, it can also do a much more thorough job validating. Also, unlike is_uri() it is more concerned with only allowing real-world URIs through. Things like relative hostnames are allowed by the standards, but probably aren't wise. Conversely, null paths aren't allowed per RFC 2616 (should be '/' instead), but are allowed by this function. This function only works for fully-qualified URIs. /bob.html won't work. See RFC 3986 for the appropriate method to turn a relative URI into an absolute one given its context. Returns the untainted URI if the test value appears to be well-formed. Note that you probably want to either call this in combo with is_https_uri(). i.e. print "Good" if(is_http_uri($uri) || is_https_uri($uri)); or use the convenience method is_web_uri which is equivalent. *Arguments* $value The potential URI to test. *Returns* Returns the untainted URI on success, undef on failure. *Notes, Exceptions, & Bugs* This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. is_https_uri - is the value a well-formed HTTPS uri? is_https_uri($value); *Description* See is_http_uri() for details. This version only likes the https URI scheme. Otherwise it's identical to is_http_uri() *Arguments* $value The potential URI to test. *Returns* Returns the untainted URI on success, undef on failure. *Notes, Exceptions, & Bugs* This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. is_web_uri - is the value a well-formed HTTP or HTTPS uri? is_web_uri($value); *Description* This is just a convinience method that combines is_http_uri and is_https_uri to accept most common real-world URLs. *Arguments* $value The potential URI to test. *Returns* Returns the untainted URI on success, undef on failure. *Notes, Exceptions, & Bugs* This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. is_tel_uri - is the value a well-formed telephone uri? is_tel_uri($value); *Description* Specialized version of is_uri() that only likes tel: urls. As a result, it can also do a much more thorough job validating according to RFC 3966. Returns the untainted URI if the test value appears to be well-formed. *Arguments* $value The potential URI to test. *Returns* Returns the untainted URI on success, undef on failure. *Notes, Exceptions, & Bugs* This function does not make any attempt to check whether the URI is accessible or 'makes sense' in any meaningful way. It just checks that it is formatted correctly. SEE ALSO URI, RFC 3986, RFC 3966, RFC 4694, RFC 4759, RFC 4904 AUTHOR Richard Sonnen . is_tel_uri by David Dick . COPYRIGHT Copyright (c) 2005 Richard Sonnen. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Data-Validate-URI-0.06/Changes0000644000076400007640000000067311716003443015366 0ustar sonnensonnenRevision history for Perl extension Data::Validate::URI 0.06 20120211 - Adding David Dick's is_tel_uri patch 0.04 20080408 - Checking that hex escapes include two characters. Thanks to Steve West. 0.04 20071125 - Allowing IPs in authority section of http/https URLs 0.03 20071029 - fixed hex encoding bug. Thanks to Frank Wiles. 0.02 20071016 - fixed typo in POD. Thanks to Tadghe Danu. 0.01 20050915 - original version Data-Validate-URI-0.06/INSTALL0000644000076400007640000000040310312101500015073 0ustar sonnensonnenINSTALLATION ============ First unpack the kit, if you have not already done so: tar -xzvf Data-Validate-URI-x.xx.tar.gz cd Data-Validate-URI-x.xx Data::Validate::URI can be installed with: perl Makefile.PL make make test make install Data-Validate-URI-0.06/Makefile.PL0000644000076400007640000000116010722361525016041 0ustar sonnensonnenuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Data::Validate::URI', 'VERSION_FROM' => 'lib/Data/Validate/URI.pm', # finds $VERSION 'DISTNAME' => 'Data-Validate-URI', 'AUTHOR' => 'Richard Sonnen (sonnen@richardsonnen.com)', 'PREREQ_PM' => { 'Data::Validate::Domain' => 0, 'Data::Validate::IP' => 0, }, 'dist' => { 'COMPRESS' => 'gzip -9f', 'SUFFIX' => 'gz', 'ZIP' => '/usr/bin/zip', 'ZIPFLAGS' => '-rl', }, ); Data-Validate-URI-0.06/META.yml0000664000076400007640000000110111716003460015330 0ustar sonnensonnen--- #YAML:1.0 name: Data-Validate-URI version: 0.06 abstract: ~ author: - Richard Sonnen (sonnen@richardsonnen.com) license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Data::Validate::Domain: 0 Data::Validate::IP: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.55_02 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Data-Validate-URI-0.06/t/0000755000076400007640000000000011716003460014327 5ustar sonnensonnenData-Validate-URI-0.06/t/is_http_uri.t0000644000076400007640000000350310722360510017044 0ustar sonnensonnen#!/usr/bin/perl # ------------------------------------------------------------------------------- # test harness for Data::Validate::URI::is_http_uri # # Author: Richard Sonnen (http://www.richardsonnen.com/) # ------------------------------------------------------------------------------- use lib './t'; use ExtUtils::TBone; use lib './blib'; use Data::Validate::URI qw(is_http_uri); my $t = ExtUtils::TBone->typical(); $t->begin(13); $t->msg("testing is_http_uri..."); # valid $t->ok(defined(is_http_uri('http://www.richardsonnen.com/')), 'http://www.richardsonnen.com/'); $t->ok(defined(is_http_uri('http://www.richardsonnen.com')), 'http://www.richardsonnen.com'); $t->ok(defined(is_http_uri('http://www.richardsonnen.com/foo/bar/test.html')), 'http://www.richardsonnen.com/foo/bar/test.html'); $t->ok(defined(is_http_uri('http://www.richardsonnen.com/?foo=bar')), 'http://www.richardsonnen.com/?foo=bar'); $t->ok(defined(is_http_uri('http://www.richardsonnen.com:8080/test.html')), 'http://www.richardsonnen.com:8080/test.html'); $t->ok(defined(is_http_uri('http://example.w3.org/path%20with%20spaces.html')), 'http://example.w3.org/path%20with%20spaces.html'); $t->ok(defined(is_http_uri('http://192.168.0.1/')), 'http://192.168.0.1/'); # invalid $t->ok(!defined(is_http_uri('')), "bad: ''"); $t->ok(!defined(is_http_uri('ftp://ftp.richardsonnen.com')), "bad: 'ftp://ftp.richardsonnen.com'"); $t->ok(!defined(is_http_uri('http:www.richardsonnen.com')), "bad: 'http:www.richardsonnen.com'"); $t->ok(!defined(is_http_uri('https://www.richardsonnen.com')), "bad: 'https://www.richardsonnen.com'"); # as an object my $v = Data::Validate::URI->new(); $t->ok(defined($v->is_http_uri('http://www.richardsonnen.com/')), 'http://www.richardsonnen.com/ (object)'); $t->ok(!defined($v->is_http_uri('foo')), 'bad: foo (object)'); # we're done $t->end(); Data-Validate-URI-0.06/t/is_web_uri.t0000644000076400007640000000453710722360563016662 0ustar sonnensonnen#!/usr/bin/perl # ------------------------------------------------------------------------------- # test harness for Data::Validate::URI::is_web_uri # # Author: Richard Sonnen (http://www.richardsonnen.com/) # ------------------------------------------------------------------------------- use lib './t'; use ExtUtils::TBone; use lib './blib'; use Data::Validate::URI qw(is_web_uri); my $t = ExtUtils::TBone->typical(); $t->begin(18); $t->msg("testing is_web_uri..."); # valid $t->ok(defined(is_web_uri('https://www.richardsonnen.com/')), 'https://www.richardsonnen.com/'); $t->ok(defined(is_web_uri('https://www.richardsonnen.com')), 'https://www.richardsonnen.com'); $t->ok(defined(is_web_uri('https://www.richardsonnen.com/foo/bar/test.html')), 'https://www.richardsonnen.com/foo/bar/test.html'); $t->ok(defined(is_web_uri('https://www.richardsonnen.com/?foo=bar')), 'https://www.richardsonnen.com/?foo=bar'); $t->ok(defined(is_web_uri('https://www.richardsonnen.com:8080/test.html')), 'https://www.richardsonnen.com:8080/test.html'); $t->ok(defined(is_web_uri('http://www.richardsonnen.com/')), 'http://www.richardsonnen.com/'); $t->ok(defined(is_web_uri('http://www.richardsonnen.com')), 'http://www.richardsonnen.com'); $t->ok(defined(is_web_uri('http://www.richardsonnen.com/foo/bar/test.html')), 'http://www.richardsonnen.com/foo/bar/test.html'); $t->ok(defined(is_web_uri('http://www.richardsonnen.com/?foo=bar')), 'http://www.richardsonnen.com/?foo=bar'); $t->ok(defined(is_web_uri('http://www.richardsonnen.com:8080/test.html')), 'http://www.richardsonnen.com:8080/test.html'); $t->ok(defined(is_web_uri('http://example.w3.org/path%20with%20spaces.html')), 'http://example.w3.org/path%20with%20spaces.html'); $t->ok(defined(is_web_uri('http://192.168.0.1/')), 'http://192.168.0.1/'); # invalid $t->ok(!defined(is_web_uri('')), "bad: ''"); $t->ok(!defined(is_web_uri('ftp://ftp.richardsonnen.com')), "bad: 'ftp://ftp.richardsonnen.com'"); $t->ok(!defined(is_web_uri('https:www.richardsonnen.com')), "bad: 'http:www.richardsonnen.com'"); $t->ok(!defined(is_web_uri('http:www.richardsonnen.com')), "bad: 'http:www.richardsonnen.com'"); # as an object my $v = Data::Validate::URI->new(); $t->ok(defined($v->is_web_uri('http://www.richardsonnen.com/')), 'http://www.richardsonnen.com/ (object)'); $t->ok(!defined($v->is_web_uri('foo')), 'bad: foo (object)'); # we're done $t->end(); Data-Validate-URI-0.06/t/ExtUtils/0000755000076400007640000000000011716003460016110 5ustar sonnensonnenData-Validate-URI-0.06/t/ExtUtils/TBone.pm0000444000076400007640000003044410155426114017461 0ustar sonnensonnenpackage ExtUtils::TBone; =head1 NAME ExtUtils::TBone - a "skeleton" for writing "t/*.t" test files. =head1 SYNOPSIS Include a copy of this module in your t directory (as t/ExtUtils/TBone.pm), and then write your t/*.t files like this: use lib "./t"; # to pick up a ExtUtils::TBone use ExtUtils::TBone; # Make a tester... here are 3 different alternatives: my $T = typical ExtUtils::TBone; # standard log my $T = new ExtUtils::TBone; # no log my $T = new ExtUtils::TBone "testout/Foo.tlog"; # explicit log # Begin testing, and expect 3 tests in all: $T->begin(3); # expect 3 tests $T->msg("Something for the log file"); # message for the log # Run some tests: $T->ok($this); # test 1: no real info logged $T->ok($that, # test 2: logs a comment "Is that ok, or isn't it?"); $T->ok(($this eq $that), # test 3: logs comment + vars "Do they match?", This => $this, That => $that); # That last one could have also been written... $T->ok_eq($this, $that); # does 'eq' and logs operands $T->ok_eqnum($this, $that); # does '==' and logs operands # End testing: $T->end; =head1 DESCRIPTION This module is intended for folks who release CPAN modules with "t/*.t" tests. It makes it easy for you to output syntactically correct test-output while at the same time logging all test activity to a log file. Hopefully, bug reports which include the contents of this file will be easier for you to investigate. =head1 OUTPUT =head2 Standard output Pretty much as described by C, with a special "# END" comment placed at the very end: 1..3 ok 1 not ok 2 ok 3 # END =head1 Log file A typical log file output by this module looks like this: 1..3 ** A message logged with msg(). ** Another one. 1: My first test, using test(): how'd I do? 1: ok 1 ** Yet another message. 2: My second test, using test_eq()... 2: A: The first string 2: B: The second string 2: not ok 2 3: My third test. 3: ok 3 # END Each test() is logged with the test name and results, and the test-number prefixes each line. This allows you to scan a large file easily with "grep" (or, ahem, "perl"). A blank line follows each test's record, for clarity. =head1 PUBLIC INTERFACE =cut # Globals: use strict; use vars qw($VERSION); use FileHandle; use File::Basename; # The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = substr q$Revision: 1.124 $, 10; #------------------------------ =head2 Construction =over 4 =cut #------------------------------ =item new [ARGS...] I Create a new tester. Any arguments are sent to log_open(). =cut sub new { my $self = bless { OUT =>\*STDOUT, Begin=>0, End =>0, Count=>0, }, shift; $self->log_open(@_) if @_; $self; } #------------------------------ =item typical I Create a typical tester. Use this instead of new() for most applicaitons. The directory "testout" is created for you automatically, to hold the output log file, and log_warnings() is invoked. =cut sub typical { my $class = shift; my ($tfile) = basename $0; unless (-d "testout") { mkdir "testout", 0755 or die "Couldn't create a 'testout' subdirectory: $!\n"; ### warn "$class: created 'testout' directory\n"; } my $self = $class->new($class->catfile('.', 'testout', "${tfile}log")); $self->log_warnings; $self; } #------------------------------ # DESTROY #------------------------------ # Class method, destructor. # Automatically closes the log. # sub DESTROY { $_[0]->log_close; } #------------------------------ =back =head2 Doing tests =over 4 =cut #------------------------------ =item begin NUMTESTS I Start testing. This outputs the 1..NUMTESTS line to the standard output. =cut sub begin { my ($self, $n) = @_; return if $self->{Begin}++; $self->l_print("1..$n\n\n"); print {$self->{OUT}} "1..$n\n"; } #------------------------------ =item end I Indicate the end of testing. This outputs a "# END" line to the standard output. =cut sub end { my ($self) = @_; return if $self->{End}++; $self->l_print("# END\n"); print {$self->{OUT}} "# END\n"; } #------------------------------ =item ok BOOL, [TESTNAME], [PARAMHASH...] I Do a test, and log some information connected with it. This outputs the test result lines to the standard output: ok 12 not ok 13 Use it like this: $T->ok(-e $dotforward); Or better yet, like this: $T->ok((-e $dotforward), "Does the user have a .forward file?"); Or even better, like this: $T->ok((-e $dotforward), "Does the user have a .forward file?", User => $ENV{USER}, Path => $dotforward, Fwd => $ENV{FWD}); That last one, if it were test #3, would be logged as: 3: Does the user have a .forward file? 3: User: "alice" 3: Path: "/home/alice/.forward" 3: Fwd: undef 3: ok You get the idea. Note that defined quantities are logged with delimiters and with all nongraphical characters suitably escaped, so you can see evidence of unexpected whitespace and other badnasties. Had "Fwd" been the string "this\nand\nthat", you'd have seen: 3: Fwd: "this\nand\nthat" And unblessed array refs like ["this", "and", "that"] are treated as multiple values: 3: Fwd: "this" 3: Fwd: "and" 3: Fwd: "that" =cut sub ok { my ($self, $ok, $test, @ps) = @_; ++($self->{Count}); # next test # Report to harness: my $status = ($ok ? "ok " : "not ok ") . $self->{Count}; print {$self->{OUT}} $status, "\n"; # Log: $self->ln_print($test, "\n") if $test; while (@ps) { my ($k, $v) = (shift @ps, shift @ps); my @vs = ((ref($v) and (ref($v) eq 'ARRAY'))? @$v : ($v)); foreach (@vs) { if (!defined($_)) { # value not defined: output keyword $self->ln_print(qq{ $k: undef\n}); } else { # value defined: output quoted, encoded form s{([\n\t\x00-\x1F\x7F-\xFF\\\"])} {'\\'.sprintf("%02X",ord($1)) }exg; s{\\0A}{\\n}g; $self->ln_print(qq{ $k: "$_"\n}); } } } $self->ln_print($status, "\n"); $self->l_print("\n"); 1; } #------------------------------ =item ok_eq ASTRING, BSTRING, [TESTNAME], [PARAMHASH...] I Convenience front end to ok(): test whether C, and logs the operands as 'A' and 'B'. =cut sub ok_eq { my ($self, $this, $that, $test, @ps) = @_; $self->ok(($this eq $that), ($test || "(Is 'A' string-equal to 'B'?)"), A => $this, B => $that, @ps); } #------------------------------ =item ok_eqnum ANUM, BNUM, [TESTNAME], [PARAMHASH...] I Convenience front end to ok(): test whether C, and logs the operands as 'A' and 'B'. =cut sub ok_eqnum { my ($self, $this, $that, $test, @ps) = @_; $self->ok(($this == $that), ($test || "(Is 'A' numerically-equal to 'B'?)"), A => $this, B => $that, @ps); } #------------------------------ =back =head2 Logging messages =over 4 =cut #------------------------------ =item log_open PATH I Open a log file for messages to be output to. This is invoked for you automatically by C and C. =cut sub log_open { my ($self, $path) = @_; $self->{LogPath} = $path; $self->{LOG} = FileHandle->new(">$path") || die "open $path: $!"; $self; } #------------------------------ =item log_close I Close the log file and stop logging. You shouldn't need to invoke this directly; the destructor does it. =cut sub log_close { my $self = shift; close(delete $self->{LOG}) if $self->{LOG}; } #------------------------------ =item log_warnings I Invoking this redefines $SIG{__WARN__} to log to STDERR and to the tester's log. This is automatically invoked when using the C constructor. =cut sub log_warnings { my ($self) = @_; $SIG{__WARN__} = sub { print STDERR $_[0]; $self->log("warning: ", $_[0]); }; } #------------------------------ =item log MESSAGE... I Log a message to the log file. No alterations are made on the text of the message. See msg() for an alternative. =cut sub log { my $self = shift; print {$self->{LOG}} @_ if $self->{LOG}; } #------------------------------ =item msg MESSAGE... I Log a message to the log file. Lines are prefixed with "** " for clarity, and a terminating newline is forced. =cut sub msg { my $self = shift; my $text = join '', @_; chomp $text; $text =~ s{^}{** }gm; $self->l_print($text, "\n"); } #------------------------------ # # l_print MESSAGE... # # Instance method, private. # Print to the log file if there is one. # sub l_print { my $self = shift; print { $self->{LOG} } @_ if $self->{LOG}; } #------------------------------ # # ln_print MESSAGE... # # Instance method, private. # Print to the log file, prefixed by message number. # sub ln_print { my $self = shift; foreach (split /\n/, join('', @_)) { $self->l_print("$self->{Count}: $_\n"); } } #------------------------------ =back =head2 Utilities =over 4 =cut #------------------------------ =item catdir DIR, ..., DIR I Concatenate several directories into a path ending in a directory. Lightweight version of the one in C; this method dates back to a more-innocent time when File::Spec was younger and less ubiquitous. Paths are assumed to be absolute. To signify a relative path, the first DIR must be ".", which is processed specially. On Mac, the path I end in a ':'. On Unix, the path I end in a '/'. =cut sub catdir { my $self = shift; my $relative = shift @_ if ($_[0] eq '.'); if ($^O eq 'Mac') { return ($relative ? ':' : '') . (join ':', @_) . ':'; } else { return ($relative ? './' : '/') . join '/', @_; } } #------------------------------ =item catfile DIR, ..., DIR, FILE I Like catdir(), but last element is assumed to be a file. Note that, at a minimum, you must supply at least a single DIR. =cut sub catfile { my $self = shift; my $file = pop; if ($^O eq 'Mac') { return $self->catdir(@_) . $file; } else { return $self->catdir(@_) . "/$file"; } } #------------------------------ =back =head1 VERSION $Id: TBone.pm,v 1.124 2001/08/20 20:30:07 eryq Exp $ =head1 CHANGE LOG =over 4 =item Version 1.124 (2001/08/20) The terms-of-use have been placed in the distribution file "COPYING". Also, small documentation tweaks were made. =item Version 1.122 (2001/08/20) Changed output of C<"END"> to C<"# END">; apparently, "END" is not a directive. Maybe it never was. I The storyteller need not say "the end" aloud; Silence is enough. Automatically invoke C when constructing via C. =item Version 1.120 (2001/08/17) Added log_warnings() to support the logging of SIG{__WARN__} messages to the log file (if any). =item Version 1.116 (2000/03/23) Cosmetic improvements only. =item Version 1.112 (1999/05/12) Added lightweight catdir() and catfile() (a la File::Spec) to enhance portability to Mac environment. =item Version 1.111 (1999/04/18) Now uses File::Basename to create "typical" logfile name, for portability. =item Version 1.110 (1999/04/17) Fixed bug in constructor that surfaced if no log was being used. =back Created: Friday-the-13th of February, 1998. =head1 AUTHOR Eryq (F). President, ZeeGee Software Inc. (F). Go to F for the latest downloads and on-line documentation for this module. Enjoy. Yell if it breaks. =cut #------------------------------ 1; __END__ my $T = new ExtUtils::TBone "testout/foo.tlog"; $T->begin(3); $T->msg("before 1\nor 2"); $T->ok(1, "one"); $T->ok(2, "Two"); $T->ok(3, "Three", Roman=>'III', Arabic=>[3, '03'], Misc=>"3\nor 3"); $T->end; 1; Data-Validate-URI-0.06/t/is_tel_uri.t0000644000076400007640000000644411716002650016662 0ustar sonnensonnen#!/usr/bin/perl # ------------------------------------------------------------------------------- # test harness for Data::Validate::URI::is_tel_uri # # Author: David Dick # ------------------------------------------------------------------------------- use lib './t'; use ExtUtils::TBone; use lib './blib'; use Data::Validate::URI qw(is_tel_uri); my $t = ExtUtils::TBone->typical(); $t->begin(23); $t->msg("testing is_tel_uri..."); # valid examples taken from http://tools.ietf.org/html/rfc3966#section-6 $t->ok(defined(is_tel_uri('tel:+1-201-555-0123')), 'tel:+1-201-555-0123'); $t->ok(defined(is_tel_uri('tel:7042;phone-context=example.com')), 'tel:7042;phone-context=example.com'); $t->ok(defined(is_tel_uri('tel:863-1234;phone-context=+1-914-555')), 'tel:863-1234;phone-context=+1-914-555'); # valid examples taken from http://tools.ietf.org/html/rfc4715#section-5 $t->ok(defined(is_tel_uri('tel:+17005554141;isub=12345;isub-encoding=nsap-ia5')), 'tel:+17005554141;isub=12345;isub-encoding=nsap-ia5'); # valid examples taken from http://tools.ietf.org/html/rfc4759#section-5 $t->ok(defined(is_tel_uri('tel:+441632960038;enumdi')), 'tel:+441632960038;enumdi'); # valid examples taken from http://tools.ietf.org/html/rfc4694#section-6 $t->ok(defined(is_tel_uri('tel:+1-800-123-4567;cic=+1-6789')), 'tel:+1-800-123-4567;cic=+1-6789'); $t->ok(defined(is_tel_uri('tel:+1-202-533-1234')), 'tel:+1-202-533-1234'); $t->ok(defined(is_tel_uri('tel:+1-202-533-1234;npdi;rn=+1-202-544-0000')), 'tel:+1-202-533-1234;npdi;rn=+1-202-544-0000'); $t->ok(defined(is_tel_uri('tel:+1-202-533-6789;npdi')), 'tel:+1-202-533-6789;npdi'); # valid examples taken from http://tools.ietf.org/html/rfc4904#section-5 $t->ok(defined(is_tel_uri('tel:5550100;phone-context=+1-630;tgrp=TG-1;trunk-context=example.com')), 'tel:5550100;phone-context=+1-630;tgrp=TG-1;trunk-context=example.com'); $t->ok(defined(is_tel_uri('tel:+16305550100;tgrp=TG-1;trunk-context=example.com')), 'tel:+16305550100;tgrp=TG-1;trunk-context=example.com'); $t->ok(defined(is_tel_uri('tel:+16305550100;tgrp=TG-1;trunk-context=+1-630')), 'tel:+16305550100;tgrp=TG-1;trunk-context=+1-630'); # valid examples taken from http://tools.ietf.org/html/rfc2806#section-2.6 $t->ok(defined(is_tel_uri('tel:+358-555-1234567')), 'tel:+358-555-1234567'); # invalid $t->ok(!defined(is_tel_uri('')), "bad: ''"); $t->ok(!defined(is_tel_uri('ftp://ftp.richardsonnen.com')), "bad: 'ftp://ftp.richardsonnen.com'"); $t->ok(!defined(is_tel_uri('http://www.richardsonnen.com')), "bad: 'http://www.richardsonnen.com'"); $t->ok(!defined(is_tel_uri('tels:863-1234;phone-context=+1-914-555')), 'tels:863-1234;phone-context=+1-914-555'); $t->ok(!defined(is_tel_uri('tel:+441632960038;enumdi;enumdi')), 'tel:+441632960038;enumdi;enumdi'); $t->ok(!defined(is_tel_uri('tel:+441632960038;rn=+1-202-544-0000;rn=+1-202-544-0000')), 'tel:+441632960038;rn=+1-202-544-0000;rn=+1-202-544-0000'); $t->ok(!defined(is_tel_uri('tel:+441632960038;npdi;npdi')), 'tel:+441632960038;npdi;npdi'); $t->ok(!defined(is_tel_uri('tel:+1-800-123-4567;cic=+1-6789;cic=+1-6789')), 'tel:+1-800-123-4567;cic=+1-6789;cic=+1-6789'); # as an object my $v = Data::Validate::URI->new(); $t->ok(defined($v->is_tel_uri('tel:+1-201-555-0111')), 'tel:+1-201-555-0111 (object)'); $t->ok(!defined($v->is_tel_uri('foo')), 'bad: foo (object)'); # we're done $t->end(); Data-Validate-URI-0.06/t/is_uri.t0000644000076400007640000000537410776672745016046 0ustar sonnensonnen#!/usr/bin/perl # ------------------------------------------------------------------------------- # test harness for Data::Validate::URI::is_uri # # Author: Richard Sonnen (http://www.richardsonnen.com/) # ------------------------------------------------------------------------------- use lib './t'; use ExtUtils::TBone; use lib './blib'; use Data::Validate::URI qw(is_uri); my $t = ExtUtils::TBone->typical(); $t->begin(25); $t->msg("testing is_uri..."); # valid - from RFC 3986 for the most part $t->ok(defined(is_uri('http://localhost/')), 'http://localhost/'); $t->ok(defined(is_uri('http://example.w3.org/path%20with%20spaces.html')), 'http://example.w3.org/path%20with%20spaces.html'); $t->ok(defined(is_uri('http://example.w3.org/%20')), 'http://example.w3.org/%20'); $t->ok(defined(is_uri('ftp://ftp.is.co.za/rfc/rfc1808.txt')), 'ftp://ftp.is.co.za/rfc/rfc1808.txt'); $t->ok(defined(is_uri('ftp://ftp.is.co.za/../../../rfc/rfc1808.txt')), 'ftp://ftp.is.co.za/../../../rfc/rfc1808.txt'); $t->ok(defined(is_uri('http://www.ietf.org/rfc/rfc2396.txt')), 'http://www.ietf.org/rfc/rfc2396.txt'); $t->ok(defined(is_uri('ldap://[2001:db8::7]/c=GB?objectClass?one')), 'ldap://[2001:db8::7]/c=GB?objectClass?one'); $t->ok(defined(is_uri('mailto:John.Doe@example.com')), 'mailto:John.Doe@example.com'); $t->ok(defined(is_uri('news:comp.infosystems.www.servers.unix')), 'news:comp.infosystems.www.servers.unix'); $t->ok(defined(is_uri('tel:+1-816-555-1212')), 'tel:+1-816-555-1212'); $t->ok(defined(is_uri('telnet://192.0.2.16:80/')), 'telnet://192.0.2.16:80/'); $t->ok(defined(is_uri('urn:oasis:names:specification:docbook:dtd:xml:4.1.2')), 'urn:oasis:names:specification:docbook:dtd:xml:4.1.2'); # invalid $t->ok(!defined(is_uri('')), "bad: ''"); $t->ok(!defined(is_uri('foo')), 'bad: foo'); $t->ok(!defined(is_uri('foo@bar')), 'bad: foo@bar'); $t->ok(!defined(is_uri('http://')), 'bad: http://'); # illegal characters $t->ok(!defined(is_uri('://bob/')), 'bad: ://bob/'); # empty schema $t->ok(!defined(is_uri('1http://bob')), 'bad: 1http://bob/'); # bad schema $t->ok(!defined(is_uri('1http:////foo.html')), 'bad: 1http://bob/'); # bad path $t->ok(!defined(is_uri('http://example.w3.org/%illegal.html')), 'http://example.w3.org/%illegal.html'); $t->ok(!defined(is_uri('http://example.w3.org/%a')), 'http://example.w3.org/%a'); # partial escape $t->ok(!defined(is_uri('http://example.w3.org/%a/foo')), 'http://example.w3.org/%a/foo'); # partial escape $t->ok(!defined(is_uri('http://example.w3.org/%at')), 'http://example.w3.org/%at'); # partial escape # as an object my $v = Data::Validate::URI->new(); $t->ok(defined($v->is_uri('http://www.richardsonnen.com/')), 'http://www.richardsonnen.com/ (object)'); $t->ok(!defined($v->is_uri('foo')), 'bad: foo (object)'); # we're done $t->end(); Data-Validate-URI-0.06/t/is_https_uri.t0000644000076400007640000000353410722360545017243 0ustar sonnensonnen#!/usr/bin/perl # ------------------------------------------------------------------------------- # test harness for Data::Validate::URI::is_https_uri # # Author: Richard Sonnen (http://www.richardsonnen.com/) # ------------------------------------------------------------------------------- use lib './t'; use ExtUtils::TBone; use lib './blib'; use Data::Validate::URI qw(is_https_uri); my $t = ExtUtils::TBone->typical(); $t->begin(13); $t->msg("testing is_https_uri..."); # valid $t->ok(defined(is_https_uri('https://www.richardsonnen.com/')), 'https://www.richardsonnen.com/'); $t->ok(defined(is_https_uri('https://www.richardsonnen.com')), 'https://www.richardsonnen.com'); $t->ok(defined(is_https_uri('https://www.richardsonnen.com/foo/bar/test.html')), 'https://www.richardsonnen.com/foo/bar/test.html'); $t->ok(defined(is_https_uri('https://www.richardsonnen.com/?foo=bar')), 'https://www.richardsonnen.com/?foo=bar'); $t->ok(defined(is_https_uri('https://www.richardsonnen.com:8080/test.html')), 'https://www.richardsonnen.com:8080/test.html'); $t->ok(defined(is_https_uri('https://example.w3.org/path%20with%20spaces.html')), 'http://example.w3.org/path%20with%20spaces.html'); $t->ok(defined(is_https_uri('https://192.168.0.1/')), 'http://192.168.0.1/'); # invalid $t->ok(!defined(is_https_uri('')), "bad: ''"); $t->ok(!defined(is_https_uri('http://www.richardsonnen.com/')), 'http://www.richardsonnen.com/'); $t->ok(!defined(is_https_uri('ftp://ftp.richardsonnen.com')), "bad: 'ftp://ftp.richardsonnen.com'"); $t->ok(!defined(is_https_uri('https:www.richardsonnen.com')), "bad: 'https:www.richardsonnen.com'"); # as an object my $v = Data::Validate::URI->new(); $t->ok(defined($v->is_https_uri('https://www.richardsonnen.com/')), 'https://www.richardsonnen.com/ (object)'); $t->ok(!defined($v->is_https_uri('foo')), 'bad: foo (object)'); # we're done $t->end(); Data-Validate-URI-0.06/MANIFEST0000644000076400007640000000036211716002313015212 0ustar sonnensonnenChanges Makefile.PL MANIFEST INSTALL README lib/Data/Validate/URI.pm t/ExtUtils/TBone.pm t/is_uri.t t/is_http_uri.t t/is_tel_uri.t t/is_https_uri.t t/is_web_uri.t META.yml Module meta-data (added by MakeMaker)