├── .gitignore ├── t ├── zzz_author_tests │ ├── 101_pod.t │ ├── 102_pod_coverage.t │ ├── 130_permissions.t │ ├── 140_git.t │ └── 120_versions.t ├── test_no_import.t ├── test_sub_named.t ├── zip │ ├── 241_vatican-city.t │ ├── 221_monaco.t │ ├── 231_san-marino.t │ ├── 161_liechtenstein.t │ ├── 141_greenland.t │ ├── 101_austria.t │ ├── zip.t │ └── 112_australia.t ├── 000_boilerplate ├── test_ws.t ├── number │ ├── number.t │ ├── 701_squares.t │ ├── 123_integer_places.t │ ├── 121_integer_places.t │ ├── 131_integer_sep.t │ ├── 122_integer_places.t │ └── decimal.t ├── test___luhn.t ├── URI │ ├── tv.t │ ├── file.t │ ├── news.t │ ├── pop.t │ ├── nntp.t │ ├── telnet.t │ ├── tel.t │ ├── http.t │ ├── prospero.t │ ├── fax.t │ ├── wais.t │ └── gopher.t ├── test_list.t ├── test_sub.t ├── net │ ├── 102_ipv4_strict.t │ ├── 101_ipv4.t │ ├── 131_domain.t │ └── 121_mac.t ├── test_curry.t ├── test_i.t ├── SEN │ └── usa_ssn.t ├── comment │ ├── html.t │ ├── pascal.t │ └── delimited.t └── test_balanced.t ├── MANIFEST.SKIP ├── COPYRIGHT ├── LICENSE ├── TODO ├── COPYRIGHT.MIT ├── COPYRIGHT.BSD ├── fix_copyright ├── fix_versions ├── lib └── Regexp │ └── Common │ ├── whitespace.pm │ ├── URI │ ├── RFC1035.pm │ ├── tv.pm │ ├── pop.pm │ ├── file.pm │ ├── RFC2384.pm │ ├── prospero.pm │ ├── telnet.pm │ ├── wais.pm │ ├── fax.pm │ ├── tel.pm │ ├── http.pm │ ├── news.pm │ ├── RFC1808.pm │ └── gopher.pm │ ├── _support.pm │ ├── lingua.pm │ ├── CC.pm │ ├── URI.pm │ ├── SEN.pm │ ├── profanity.pm │ └── list.pm ├── MANIFEST ├── Util └── condense ├── Makefile.PL ├── README └── COPYRIGHT.AL /.gitignore: -------------------------------------------------------------------------------- 1 | Releases 2 | Makefile 3 | blib 4 | pm_to_blib 5 | *.tar.gz 6 | MYMETA.* 7 | *.pdf 8 | *.txt 9 | *.csv 10 | -------------------------------------------------------------------------------- /t/zzz_author_tests/101_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Test::More; 10 | 11 | eval "use Test::Pod 1.00; 1" or 12 | plan (skip_all => "Test::Pod required for testing POD"); 13 | 14 | all_pod_files_ok (); 15 | 16 | 17 | __END__ 18 | -------------------------------------------------------------------------------- /t/test_no_import.t: -------------------------------------------------------------------------------- 1 | # LOAD 2 | BEGIN {print "1..3\n";} 3 | 4 | use Regexp::Common qw /no_defaults/; 5 | 6 | print "ok 1\n"; 7 | 8 | print defined &Regexp::Common::URL::pattern ? "not ok 2\n" : "ok 2\n"; 9 | 10 | # Make sure $; isn't modified. 11 | print $; eq "\034" ? "ok 3" : "not ok 3"; 12 | print ' # $; eq "\034"', "\n"; 13 | 14 | __END__ 15 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | .git 2 | .gitignore 3 | MANIFEST.SKIP 4 | .*.tar.gz 5 | Releases 6 | fix_versions 7 | fix_copyright 8 | Data/* 9 | Util/* 10 | t/000_boilerplate 11 | t/zzz_author_tests/101_pod.t 12 | t/zzz_author_tests/102_pod_coverage.t 13 | t/zzz_author_tests/120_versions.t 14 | t/zzz_author_tests/130_permissions.t 15 | t/zzz_author_tests/140_git.t 16 | -------------------------------------------------------------------------------- /t/zzz_author_tests/102_pod_coverage.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Test::More; 10 | 11 | 12 | eval "use Test::Pod::Coverage 1.00; 1" or 13 | plan (skip_all => "Test::Pod::Coverage required for testing POD coverage"); 14 | 15 | all_pod_coverage_ok ({private => [qr /^/]}); 16 | 17 | 18 | __END__ 19 | -------------------------------------------------------------------------------- /COPYRIGHT: -------------------------------------------------------------------------------- 1 | This software is Copyright (c) 2001 - 2008, Damian Conway and Abigail. 2 | 3 | This module is free software, and maybe used under any of the following 4 | licenses: 5 | 6 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 7 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 8 | 3) The BSD License. See the file COPYRIGHT.BSD. 9 | 4) The MIT License. See the file COPYRIGHT.MIT. 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This software is Copyright (c) 2001 - 2008, Damian Conway and Abigail. 2 | 3 | This module is free software, and maybe used under any of the following 4 | licenses: 5 | 6 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 7 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 8 | 3) The BSD License. See the file COPYRIGHT.BSD. 9 | 4) The MIT License. See the file COPYRIGHT.MIT. 10 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - URIs: 2 | + As defined in RFC 1738. 3 | + More of them. 4 | - Dates: 5 | + localtime dates. 6 | + ISO Dates. 7 | + An inverse of strftime? 8 | - numbers: 9 | + Decimal numbers (e.g. 7.5, 0.3, .99, 15, but not 1.23E5). 10 | + Roman numbers >= 4000. Unicode? 11 | + Prime numbers? Fibonacci? Other special numbers? 12 | + Ranges of numbers. 13 | - postal codes. 14 | + Lots more, especially British and Canadians. 15 | - Email addresses. 16 | + RFC 822/2822. 17 | -------------------------------------------------------------------------------- /t/test_sub_named.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common qw (RE_balanced RE_num_real); 10 | ok; 11 | 12 | try RE_balanced; 13 | pass '(a(b))'; 14 | fail '(a(b)'; 15 | 16 | try RE_num_real; 17 | pass '-1.234e+567', qw( - 1.234 1 . 234 e +567 + 567 ); 18 | 19 | try RE_num_real(-base=>2,-expon=>'x2\^'); 20 | pass '-101.010x2^101010', qw( - 101.010 101 . 010 x2^ 101010 ), "", "101010"; 21 | -------------------------------------------------------------------------------- /t/zzz_author_tests/130_permissions.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Test::More; 10 | 11 | 12 | SKIP: { 13 | open my $fh, "<", "MANIFEST" or do { 14 | skip "Failed to open MANIFEST", 1; 15 | }; 16 | while (<$fh>) { 17 | chomp; 18 | s/\s+Module.*//; 19 | unless (-e) { 20 | fail "$_ does not exist"; 21 | next; 22 | } 23 | SKIP: { 24 | my $mode = (stat) [2]; 25 | skip "Failed to grab permissions of $_", 1 unless $mode; 26 | my $perm = $mode & 07777; 27 | 28 | is $perm, /\.t/ ? 0755 : 0644, "Permissions of $_" 29 | } 30 | } 31 | } 32 | 33 | done_testing; 34 | 35 | __END__ 36 | -------------------------------------------------------------------------------- /t/zip/241_vatican-city.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use lib "."; 8 | 9 | use Regexp::Common; 10 | use Test::More; 11 | use t::zip::Zip; 12 | 13 | my $r = eval "require Test::Regexp; 1"; 14 | 15 | unless ($r) { 16 | print "1..0 # SKIP Test::Regexp not found\n"; 17 | exit; 18 | } 19 | 20 | 21 | test_zips country => "Vatican City", 22 | name => "Vatican City zip codes", 23 | prefix => { 24 | iso => "VA", 25 | cept => "VA", 26 | invalid => "CH", 27 | }, 28 | prefix_test_set => [], 29 | ; 30 | 31 | 32 | done_testing; 33 | 34 | 35 | sub valid_zip_codes { 36 | "00120", 37 | } 38 | 39 | 40 | __END__ 41 | -------------------------------------------------------------------------------- /t/zip/221_monaco.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use lib "."; 8 | 9 | use Regexp::Common; 10 | use Test::More; 11 | use t::zip::Zip; 12 | 13 | my $r = eval "require Test::Regexp; 1"; 14 | 15 | unless ($r) { 16 | print "1..0 # SKIP Test::Regexp not found\n"; 17 | exit; 18 | } 19 | 20 | 21 | test_zips country => "Monaco", 22 | name => "Monaco zip codes", 23 | prefix => { 24 | iso => "MC", 25 | cept => "MC", 26 | invalid => "FR", 27 | }, 28 | prefix_test_set => [98010, 98088], 29 | ; 30 | 31 | 32 | done_testing; 33 | 34 | 35 | sub valid_zip_codes { 36 | 98000 .. 98099, 37 | } 38 | 39 | 40 | __END__ 41 | -------------------------------------------------------------------------------- /t/zip/231_san-marino.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use lib "."; 8 | 9 | use Regexp::Common; 10 | use Test::More; 11 | use t::zip::Zip; 12 | 13 | my $r = eval "require Test::Regexp; 1"; 14 | 15 | unless ($r) { 16 | print "1..0 # SKIP Test::Regexp not found\n"; 17 | exit; 18 | } 19 | 20 | 21 | test_zips country => "San Marino", 22 | name => "San Marino zip codes", 23 | prefix => { 24 | iso => "SM", 25 | cept => "SM", 26 | invalid => "IT", 27 | }, 28 | prefix_test_set => [47892, 47897], 29 | ; 30 | 31 | 32 | done_testing; 33 | 34 | 35 | sub valid_zip_codes { 36 | 47890 .. 47899 37 | } 38 | 39 | 40 | __END__ 41 | -------------------------------------------------------------------------------- /t/zip/161_liechtenstein.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use lib "."; 8 | 9 | use Regexp::Common; 10 | use Test::More; 11 | use t::zip::Zip; 12 | 13 | my $r = eval "require Test::Regexp; 1"; 14 | 15 | unless ($r) { 16 | print "1..0 # SKIP Test::Regexp not found\n"; 17 | exit; 18 | } 19 | 20 | 21 | test_zips country => "Liechtenstein", 22 | name => "Liechtenstein zip codes", 23 | prefix => { 24 | iso => "LI", 25 | cept => "LIE", 26 | invalid => "CH", 27 | }, 28 | prefix_test_set => [9489, 9490], 29 | ; 30 | 31 | 32 | done_testing; 33 | 34 | 35 | sub valid_zip_codes { 36 | 9485 .. 9498 37 | } 38 | 39 | 40 | __END__ 41 | -------------------------------------------------------------------------------- /t/zzz_author_tests/140_git.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Test::More; 10 | 11 | unless (-f ".git/config") { 12 | plan skip_all => "This is not a git repository"; 13 | exit; 14 | } 15 | 16 | undef $ENV {PATH}; 17 | my ($GIT) = grep {-x} qw [/opt/git/bin/git /opt/local/bin/git]; 18 | my ($HEAD) = grep {-x} qw [/usr/bin/head]; 19 | 20 | my @output = `$GIT status --porcelain`; 21 | 22 | diag @output; 23 | ok @output == 0, "All files are checked in"; 24 | 25 | my @tags = sort grep {/^release/} `$GIT tag`; 26 | 27 | chomp (my $final_tag = $tags [-1]); 28 | 29 | my $changes_line = `$HEAD -1 Changes`; 30 | 31 | ok $final_tag && 32 | $changes_line && 33 | $final_tag eq "release-" . ($changes_line =~ /^Version ([0-9]{10})/) [0], 34 | "git tag matches version"; 35 | 36 | 37 | done_testing; 38 | -------------------------------------------------------------------------------- /t/000_boilerplate: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use Regexp::Common; 8 | use Test::More; 9 | 10 | my $r = eval "require Test::Regexp; 1"; 11 | 12 | unless ($r) { 13 | print "1..0 # SKIP Test::Regexp not found\n"; 14 | exit; 15 | } 16 | 17 | sub make_test { 18 | my ($name, $base, @options) = @_; 19 | my $pat = $base; 20 | while (@options) { 21 | my $opt = shift @options; 22 | if (@options && $options [0] !~ /^-/) { 23 | my $val = shift @options; 24 | $pat = $$pat {$opt => $val}; 25 | $name .= ", $opt => $val"; 26 | } 27 | else { 28 | $pat = $$pat {$opt}; 29 | $name .= ", $opt"; 30 | } 31 | } 32 | my $keep = $$pat {-keep}; 33 | Test::Regexp:: -> new -> init ( 34 | pattern => $pat, 35 | keep_pattern => $keep, 36 | name => $name, 37 | ); 38 | } 39 | 40 | 41 | done_testing; 42 | 43 | 44 | __END__ 45 | -------------------------------------------------------------------------------- /t/test_ws.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/$_[0]/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common; 10 | ok; 11 | 12 | try $RE{ws}{crop}; 13 | 14 | pass " a sentence here\t\t"; 15 | pass " a sentence here"; 16 | pass "a sentence here\t\t"; 17 | fail "a sentence here"; 18 | 19 | ok $RE{ws}{crop}->matches(" a sentence here\t\t"); 20 | ok $RE{ws}{crop}->matches(" a sentence here"); 21 | ok $RE{ws}{crop}->matches("a sentence here\t\t"); 22 | ok ! $RE{ws}{crop}->matches("a sentence here"); 23 | 24 | ok 'a sentence here' eq $RE{ws}{crop}->subs(" a sentence here\t\t"); 25 | ok 'a sentence here' eq $RE{ws}{crop}->subs(" a sentence here"); 26 | ok 'a sentence here' eq $RE{ws}{crop}->subs("a sentence here\t\t"); 27 | ok 'a sentence here' eq $RE{ws}{crop}->subs("a sentence here"); 28 | -------------------------------------------------------------------------------- /t/zip/141_greenland.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use lib "."; 8 | 9 | use Regexp::Common; 10 | use Test::More; 11 | use t::zip::Zip; 12 | 13 | my $r = eval "require Test::Regexp; 1"; 14 | 15 | unless ($r) { 16 | print "1..0 # SKIP Test::Regexp not found\n"; 17 | exit; 18 | } 19 | 20 | 21 | test_zips country => "Greenland", 22 | name => "Greenlandic zip codes", 23 | prefix => { 24 | iso => "GL", 25 | cept => "GL", 26 | invalid => "DE", 27 | }, 28 | prefix_test_set => [3940, 3955], 29 | ; 30 | 31 | 32 | done_testing; 33 | 34 | 35 | sub valid_zip_codes { 36 | 2412, 37 | 38 | 3900, 3905, 3910 .. 3913, 3915, 3919 .. 3924, 39 | 3930, 3932, 3940, 3950 .. 3953, 3955, 40 | 3961 .. 3962, 3964, 3970 .. 3972, 3980, 3982, 41 | 3984 .. 3985, 3992, 42 | } 43 | 44 | 45 | __END__ 46 | -------------------------------------------------------------------------------- /t/number/number.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # 4 | # Test for the support functions of Regexp::Common::number 5 | # 6 | 7 | use strict; 8 | use lib qw {blib/lib}, "."; 9 | 10 | use Regexp::Common; 11 | use t::Common; 12 | 13 | my @wrong_bases = (0, 40); 14 | my @correct_bases = (1, 29, 36); 15 | my @types = qw /decimal real/; 16 | 17 | my $tests = (@wrong_bases + @correct_bases) * @types; 18 | my $count = 0; 19 | 20 | print "1..$tests\n"; 21 | 22 | foreach my $base (@wrong_bases) { 23 | foreach my $type (@types) { 24 | eval {"" =~ $RE {num} {$type} {-base => $base}}; 25 | printf "%s %d - \$RE {num} {$type} {-base => $base}\n" => 26 | $@ && $@ =~ /Base must be between 1 and 36/ ? "ok" : "not ok", 27 | ++ $count; 28 | } 29 | } 30 | 31 | foreach my $base (@correct_bases) { 32 | foreach my $type (@types) { 33 | eval {"" =~ $RE {num} {$type} {-base => $base}}; 34 | printf "%s %d - \$RE {num} {$type} {-base => $base}\n" => 35 | $@ ? "not ok" : "ok", ++ $count; 36 | } 37 | } 38 | 39 | 40 | __END__ 41 | -------------------------------------------------------------------------------- /COPYRIGHT.MIT: -------------------------------------------------------------------------------- 1 | Copyright (c) 2001 - 2008, Damian Conway and Abigail 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /t/test___luhn.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}; 5 | 6 | use Regexp::Common; 7 | use Regexp::Common::_support qw /luhn/; 8 | 9 | use warnings; 10 | 11 | 12 | my $TESTS = 100; 13 | 14 | my @good = qw /49927398716 00000000000/; 15 | 16 | my @bad = qw /49927398717 49927398715/; 17 | 18 | 19 | # Generate a bunch of valid, and invalid, numbers. 20 | my %cache; 21 | foreach (1 .. $TESTS) { 22 | my $length = 1 + int rand (1 > rand 10 ? 100 : 20); 23 | my $s = join "" => map {int rand 10} 1 .. $length; 24 | redo if $cache {$s} ++; 25 | my $even = 1; 26 | my $sum = 0; 27 | foreach my $n (split // => $s) { 28 | $n *= 2 if $even; 29 | $sum += ($n % 10) + int ($n / 10); 30 | $even = !$even; 31 | } 32 | my $c = $sum % 10 ? 10 - ($sum % 10) : 0; 33 | my $d = $c; 34 | $d = int rand 10 while $d == $c; 35 | my $g = reverse ($s) . $c; 36 | my $b = reverse ($s) . $d; 37 | push @good => $g; 38 | push @bad => $b; 39 | } 40 | 41 | 42 | 43 | my $total = @good + @bad; 44 | 45 | print "1..$total\n"; 46 | 47 | my $c = 0; 48 | 49 | foreach my $g (@good) { 50 | print "not " unless luhn $g; 51 | print "ok ", ++ $c, " # luhn ($g)\n"; 52 | } 53 | 54 | foreach my $b (@bad) { 55 | print "not " if luhn $b; 56 | print "ok ", ++ $c, " # !luhn ($b)\n"; 57 | } 58 | 59 | 60 | __END__ 61 | -------------------------------------------------------------------------------- /t/URI/tv.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}; 5 | 6 | use Regexp::Common; 7 | 8 | $^W = 1; 9 | 10 | 11 | my $count; 12 | 13 | my $tv = qr /^$RE{URI}{tv}$/; 14 | my $keep = qr /^$RE{URI}{tv}{-keep}$/; 15 | 16 | sub mess {print ++ $count, " - $_ (@_)\n"} 17 | 18 | sub pass {print "ok "; &mess} 19 | sub fail {print "not ok "; &mess} 20 | 21 | my (@hosts, @failures); 22 | while () { 23 | chomp; 24 | last unless /\S/; 25 | push @hosts => $_; 26 | } 27 | push @hosts => ""; 28 | 29 | while () { 30 | chomp; 31 | last unless /\S/; 32 | push @failures => $_; 33 | } 34 | 35 | my $max = 1 + 2 * @hosts + @failures; 36 | 37 | print "1..$max\n"; 38 | 39 | print "ok ", ++ $count, "\n"; 40 | 41 | # print "$fail\n"; exit; 42 | 43 | foreach my $host (@hosts) { 44 | local $_ = "tv:$host"; 45 | /$tv/ ? pass "match" : fail "no match"; 46 | /$keep/ ? $1 eq $_ && $2 eq "tv" 47 | && (length $host ? $3 eq $host : !defined $3) 48 | ? pass "match; keep" : fail "match ($1, $2, $3); keep" 49 | : fail "no match; keep" 50 | } 51 | 52 | foreach (@failures) { 53 | /$tv/ ? fail "match" : pass "no match"; 54 | } 55 | 56 | 57 | __DATA__ 58 | wqed.com 59 | nbc.com 60 | abc.com 61 | abc.co.au 62 | east.hbo.com 63 | west.hbo.com 64 | bbc.co.uk 65 | 66 | TV:abc.com 67 | abc.com 68 | http:abc.com 69 | tv://abc.com 70 | tv:abc..com 71 | tv:.abc.com 72 | tv:abc-.com 73 | tv:-abc.com 74 | -------------------------------------------------------------------------------- /t/zip/101_austria.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use lib "."; 8 | 9 | use Regexp::Common; 10 | use Test::More; 11 | use t::zip::Zip; 12 | 13 | my $r = eval "require Test::Regexp; 1"; 14 | 15 | unless ($r) { 16 | print "1..0 # SKIP Test::Regexp not found\n"; 17 | exit; 18 | } 19 | 20 | 21 | test_zips country => "Austria", 22 | name => "Austrian zip codes", 23 | prefix => { 24 | iso => "AT", 25 | cept => "AUT", 26 | invalid => "FR", 27 | }, 28 | prefix_test_set => [2491, 5114], 29 | ; 30 | 31 | 32 | done_testing; 33 | 34 | 35 | sub valid_zip_codes { 36 | 1000 .. 1901, 37 | 38 | 2000 .. 2413, 2421 .. 2425, 2431 .. 2472, 2473 .. 2475, 39 | 2481 .. 2490, 2491, 2492 .. 2881, 40 | 41 | 3001 .. 3333, 3334 .. 3335, 3340 .. 3973, 42 | 43 | 4000 .. 4294, 4300 .. 4303, 4310 .. 4391, 4392, 44 | 4400 .. 4421, 4431 .. 4441, 4442 .. 4481, 4482, 45 | 4483 .. 4985, 46 | 47 | 5000 .. 5114, 5120 .. 5145, 5151 .. 5205, 5211 .. 5283, 48 | 5300 .. 5303, 5310 .. 5311, 5321 .. 5351, 5360, 49 | 5400 .. 5771, 50 | 51 | 6000 .. 6691, 6700 .. 6993, 52 | 53 | 7000 .. 7413, 7421, 7422 .. 7573, 54 | 55 | 8000 .. 8363, 8380 .. 8385, 8401 .. 8993, 56 | 57 | 9000 .. 9322, 9323, 9324 .. 9781, 9782, 58 | 9800 .. 9873, 9900 .. 9992, 59 | } 60 | 61 | 62 | __END__ 63 | -------------------------------------------------------------------------------- /COPYRIGHT.BSD: -------------------------------------------------------------------------------- 1 | Copyright (c) 2001 - 2008, Damian Conway and Abigail 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following disclaimer 12 | in the documentation and/or other materials provided with the 13 | distribution. 14 | * The names of its contributors may not be used to endorse or promote 15 | products derived from this software without specific prior 16 | written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /t/number/701_squares.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use Regexp::Common; 8 | use Test::More; 9 | 10 | use Config; 11 | 12 | my $r = eval "require Test::Regexp; 1"; 13 | 14 | unless ($r) { 15 | print "1..0 # SKIP Test::Regexp not found\n"; 16 | exit; 17 | } 18 | 19 | my $bits64 = $Config {use64bitint}; 20 | # 21 | # CPAN testers claim it fails on 5.8.8 and darwin 9.0. 22 | # 23 | $bits64 = 0 if $Config {osname} eq 'darwin' && 24 | $Config {osvers} eq '10.0' && $] == 5.010; 25 | my $MAX_POWER = $bits64 ? 31 : 15; 26 | 27 | # 28 | # The {-keep} pattern and the one without {-keep} are identical. 29 | # 30 | my $Test = Test::Regexp:: -> new -> init ( 31 | keep_pattern => $RE {num} {square} {-keep}, 32 | name => "Square numbers", 33 | ); 34 | 35 | my @squares = map {$_ * $_} 0 .. 100, map {2 ** $_} 7 .. $MAX_POWER; 36 | 37 | foreach my $square (@squares) { 38 | $Test -> match ($square, [$square], test => "$square is a square"); 39 | } 40 | 41 | my @not_squares = map {($_ * $_ - 1, $_ * $_ + 1)} 2 .. 100; 42 | 43 | { 44 | my $max_root = $bits64 ? 3037000499 : 46340; 45 | my $max_square = $max_root * $max_root; 46 | # 47 | # The first square bigger than 2^31 - 1/2^63 - 1. Note we use strings 48 | # and pre-calculated values here, avoiding Perl to use doubles. 49 | # 50 | my $big_square = $bits64 ? "9223372037000250000" : "2147488281"; 51 | $Test -> match ($max_square, [$max_square], test => "Largest square"); 52 | $Test -> no_match ($big_square, reason => "Square too big"); 53 | } 54 | 55 | foreach my $not_square (@not_squares) { 56 | $Test -> no_match ($not_square, reason => "Not a square number"); 57 | } 58 | 59 | done_testing (); 60 | 61 | 62 | __END__ 63 | -------------------------------------------------------------------------------- /t/test_list.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common; 10 | ok; 11 | 12 | # TEST COMMA-SEPARATED 13 | 14 | try $RE{list}; 15 | 16 | fail "a"; 17 | pass "a,b"; 18 | pass "a, b"; 19 | pass "a,b,c"; 20 | pass "a, b, c"; 21 | fail "a b"; 22 | fail "a b"; 23 | fail "a b c"; 24 | fail "a b c"; 25 | 26 | 27 | # TEST TAB-SEPARATED 28 | 29 | try $RE{list}{"-sep$;\t"}; 30 | 31 | fail "a"; 32 | pass "a\tb"; 33 | pass "a\tb"; 34 | pass "a\tb\tc"; 35 | pass "a\tb\tc"; 36 | fail "a b"; 37 | fail "a b"; 38 | pass "a b\tc"; 39 | fail "a b c"; 40 | 41 | 42 | # TEST WORDS 43 | 44 | try $RE{list}{and}; 45 | 46 | fail "a"; 47 | pass "a and b"; 48 | pass "a, b, and c"; 49 | pass "a, b and c"; 50 | fail "a,b,c"; 51 | fail "a, b, c"; 52 | 53 | try $RE{list}{conj}; 54 | 55 | fail "a"; 56 | pass "a and b"; 57 | pass "a, b, and c"; 58 | pass "a, b and c"; 59 | pass "a, b, or c"; 60 | pass "a, b or c"; 61 | fail "a,b,c"; 62 | fail "a, b, c"; 63 | 64 | try $RE{list}{conj}{-word => 'ou'}; 65 | 66 | fail "a"; 67 | pass "a ou b"; 68 | pass "a, b, ou c"; 69 | pass "a, b ou c"; 70 | fail "a,b,c"; 71 | fail "a, b, c"; 72 | 73 | 74 | # TRY NESTED PATTERNS 75 | 76 | 77 | try $RE{list}{"-pat$;$RE{quoted}"}; 78 | 79 | fail q{a}; 80 | pass q{'a', 'b'}; 81 | fail q{'a', 'b' and 'c'}; 82 | pass q{'a', "b", `c`}; 83 | fail q{a, b, c}; 84 | 85 | 86 | try $RE{list}{"-pat$;$RE{quoted}"}{-lastsep => '\s*(and|or)\s*'}; 87 | 88 | fail q{a}; 89 | pass q{'a' and 'b'}; 90 | pass q{'a', 'b' and 'c'}; 91 | fail q{'a', "b", `c`}; 92 | pass q{'a', "b" or `c`}; 93 | fail q{a, b, c}; 94 | -------------------------------------------------------------------------------- /t/test_sub.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common 'RE_ALL'; 10 | ok; 11 | 12 | try RE_balanced; 13 | pass '(a(b))'; 14 | fail '(a(b)'; 15 | 16 | try RE_num_real; 17 | pass '-1.234e+567', qw( - 1.234 1 . 234 e +567 + 567 ); 18 | 19 | try RE_num_dec; 20 | pass '-1.234e+567', qw( - 1.234 1 . 234 e +567 + 567 ); 21 | 22 | try RE_num_real(-base=>2,-expon=>'x2\^'); 23 | pass '-101.010x2^101010', qw( - 101.010 101 . 010 x2^ 101010 ), "", "101010"; 24 | 25 | try RE_num_bin; 26 | pass '-101.010E101010', qw( - 101.010 101 . 010 E 101010 ), "", "101010"; 27 | 28 | try RE_num_real(-base=>10, -sep); 29 | pass '-1,234,567.234e+567'; 30 | 31 | try RE_comment_C; 32 | pass '/*abc*/', qw( /* abc */ ); 33 | 34 | try RE_comment_CXX; 35 | pass '/*abc*/'; 36 | pass "// abc\n"; 37 | 38 | try RE_comment_Perl; 39 | pass "# abc\n", "#", " abc", "\n"; 40 | 41 | try RE_comment_shell; 42 | pass "# abc\n", "#", " abc", "\n"; 43 | 44 | try RE_comment_HTML; 45 | pass "", ""; 46 | 47 | 48 | try RE_delimited(-delim=>'/'); 49 | pass '/a\/b/', qw( / a\/b / ); 50 | 51 | try RE_delimited(-delim=>'/', -esc=>'/'); 52 | pass '/a//b/', qw( / a//b / ); 53 | 54 | try RE_net_IPv4; 55 | pass '123.234.1.0', qw( 123 234 1 0 ); 56 | 57 | try RE_list_conj(-word=>'(?:and|or)'); 58 | pass 'a, b, and c', ', and '; 59 | 60 | my $profane = 'uneqba'; 61 | my $contextual = 'funttref'; 62 | foreach ($profane, $contextual) { tr/A-Za-z/N-ZA-Mn-za-m/ } 63 | 64 | try RE_profanity; 65 | pass $profane; 66 | 67 | try RE_profanity_contextual; 68 | pass $contextual; 69 | -------------------------------------------------------------------------------- /t/net/102_ipv4_strict.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use Regexp::Common; 8 | use Test::More; 9 | 10 | my $r = eval "require Test::Regexp; 1"; 11 | 12 | unless ($r) { 13 | print "1..0 # SKIP Test::Regexp not found\n"; 14 | exit; 15 | } 16 | 17 | my $Test = Test::Regexp:: -> new -> init ( 18 | pattern => $RE {net} {IPv4} {strict}, 19 | keep_pattern => $RE {net} {IPv4} {strict} {-keep}, 20 | name => "Strict IPv4 addresses", 21 | ); 22 | 23 | 24 | foreach my $number (0 .. 999) { 25 | my $address = "$number.$number.$number.$number"; 26 | if ($number < 256) { 27 | $Test -> match ($address, 28 | [$address, $number, $number, $number, $number], 29 | test => "Accept number $number"); 30 | if ($number < 10) { 31 | my $address = sprintf "%d.%d.%02d.%d" => ($number) x 4; 32 | $Test -> no_match ($address, reason => "Leading 0 not allowed"); 33 | } 34 | if ($number < 100) { 35 | my $address = sprintf "%d.%03d.%d.%d" => ($number) x 4; 36 | $Test -> no_match ($address, reason => "Leading 0 not allowed"); 37 | } 38 | } 39 | else { 40 | $Test -> no_match ($address, reason => "Number exceeds 256"); 41 | } 42 | } 43 | 44 | 45 | $Test -> no_match ("1.2.3.4.5", reason => "To many octets"); 46 | $Test -> no_match ("1.2.3", reason => "No enough octets"); 47 | $Test -> no_match ("12.34.ab.56", reason => "Non numbers in octets"); 48 | $Test -> no_match ("1.1234.2.3", reason => "Too many digits in octet"); 49 | $Test -> no_match ("12:34:45:67", reason => "Incorrect separator"); 50 | $Test -> no_match ("+12.34.56.78", reason => "Garbage before address"); 51 | $Test -> no_match ("12.34.56.78 ", reason => "Garbage after address"); 52 | 53 | 54 | done_testing; 55 | -------------------------------------------------------------------------------- /t/test_curry.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common; 10 | ok; 11 | 12 | my $num = $RE{num}{real}; 13 | 14 | # TEST BASE 10 15 | 16 | try $num->{'-base' => '10'}{-sep}; 17 | 18 | pass 0; 19 | pass 1; 20 | pass 12; 21 | fail 1234567; 22 | pass 1.23456789; 23 | pass 12.23456789; 24 | pass 123.23456789; 25 | fail 1234.23456789; 26 | pass '+1'; 27 | pass '+12'; 28 | fail '+1234567.89'; 29 | pass '+1,234,567.89'; 30 | pass '-1'; 31 | pass '-12.333333333333333333333333333333333333333'; 32 | fail '-1234567'; 33 | pass -1; 34 | pass -12; 35 | fail -1234567; 36 | pass 1.2; 37 | fail "a"; 38 | fail ""; 39 | fail "1a"; 40 | fail "- 1234"; 41 | pass "1,234,567"; 42 | pass "12,345.6789"; 43 | fail "1,2345,6789"; 44 | fail "1.2345.6789"; 45 | 46 | 47 | # TEST BASE 2 48 | 49 | try $num->{'-base' => '2'}{-sep}; 50 | 51 | pass 0; 52 | pass 1; 53 | fail 12; 54 | fail 1234567; 55 | fail 1.23456789; 56 | pass '+1'; 57 | fail '+12'; 58 | fail '+101010'; 59 | fail '+101010.0001010'; 60 | pass '+101,010.0001010'; 61 | fail '+1234567.89'; 62 | pass '-1'; 63 | pass -1; 64 | fail "a"; 65 | fail ""; 66 | fail "1a"; 67 | fail "- 1010"; 68 | pass "1,001,101"; 69 | pass "1,010.1110"; 70 | fail "1,0101,0011"; 71 | fail "1.0011.0011"; 72 | 73 | try $RE{num}{bin}{-sep}; 74 | 75 | pass 0; 76 | pass 1; 77 | fail 12; 78 | fail 1234567; 79 | fail 1.23456789; 80 | pass '+1'; 81 | fail '+12'; 82 | fail '+101010'; 83 | fail '+101010.0001010'; 84 | fail '+1234567.89'; 85 | pass '-1'; 86 | pass -1; 87 | fail "a"; 88 | fail ""; 89 | fail "1a"; 90 | fail "- 1010"; 91 | pass "1,001,101"; 92 | pass "1,010.1110"; 93 | fail "1,0101,0011"; 94 | fail "1.0011.0011"; 95 | -------------------------------------------------------------------------------- /t/URI/file.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common; 8 | 9 | $^W = 1; 10 | 11 | 12 | sub create_parts; 13 | 14 | my $file = $RE {URI} {file}; 15 | 16 | my @tests = ( 17 | [file => $file => {file => NORMAL_PASS | FAIL}], 18 | ); 19 | 20 | my ($good, $bad) = create_parts; 21 | 22 | run_tests version => "Regexp::Common::URI::file", 23 | tests => \@tests, 24 | good => $good, 25 | bad => $bad, 26 | query => \&file, 27 | wanted => \&wanted; 28 | 29 | sub file { 30 | my ($tag, $host, $path) = ($_ [0], @{$_ [1]}); 31 | 32 | my $file = "file://"; 33 | $file .= $host if defined $host; 34 | $file .= "/$path" if defined $path; 35 | 36 | $file; 37 | } 38 | 39 | sub wanted { 40 | my ($tag, $parts) = @_; 41 | 42 | my @wanted; 43 | $wanted [0] = $_; 44 | $wanted [1] = "file"; 45 | $wanted [2] = $$parts [0]; 46 | $wanted [2] .= "/" . $$parts [1] if defined $$parts [1]; 47 | $wanted [3] = $$parts [0]; 48 | $wanted [4] = "/" . $$parts [1] if defined $$parts [1]; 49 | $wanted [5] = $$parts [1]; 50 | 51 | \@wanted; 52 | } 53 | 54 | 55 | sub create_parts { 56 | my (@good, @bad); 57 | 58 | # Hosts. 59 | $good [0] = ["", qw /www.abigail.freedom.nl www.PERL.com a.b.c.d.e.f.g.h.i.j.k.x 60 | 127.0.0.1 w--w--w.abigail.freedom.nl w3.abigail.freedom.nl/]; 61 | $bad [0] = [qw /www.example..com w+w.example.com w--.example.com 62 | 127.0.1 127.0.0.0.1 -w.example.com www.example.1com/]; 63 | 64 | # Paths. 65 | $good [1] = ["", qw {foo foo/bar/baz/bingo foo%00bar foo%EFbar 66 | %12%34%E6%7B %12%34/%E6%7B %12%34%E6%7B/foo 67 | ()() fnurd&.!@}]; 68 | $bad [1] = [undef, qw {foo<> foo<>bar ~abigail %GGfoo foo%F %FOfoo}, 69 | '#hubba']; 70 | 71 | return (\@good, \@bad); 72 | } 73 | 74 | 75 | __END__ 76 | -------------------------------------------------------------------------------- /fix_copyright: -------------------------------------------------------------------------------- 1 | #!/opt/perl/bin/perl 2 | 3 | use 5.010; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | use autodie; 9 | 10 | use Fcntl 'SEEK_SET'; 11 | 12 | sub find_copyright; 13 | sub fix_copyright; 14 | 15 | my $README = "README"; 16 | my @MODULES = `find lib -type f -name "*.pm"`; 17 | chomp @MODULES; 18 | push @MODULES => $README; 19 | 20 | my ($year) = (localtime) [5] + 1900; 21 | 22 | my $COPYRIGHT_OK = 1; 23 | my $COPYRIGHT_OLD = 2; 24 | my $COPYRIGHT_NONE = 3; 25 | 26 | my $count = 0; 27 | my $missing = 0; 28 | 29 | foreach my $module (@MODULES) { 30 | my $r = find_copyright $module, $year; 31 | 32 | if ($r == $COPYRIGHT_OK) { 33 | ; 34 | } 35 | elsif ($r == $COPYRIGHT_OLD) { 36 | say "Updating copyright notice in $module"; 37 | fix_copyright $module, $year; 38 | $count ++; 39 | } 40 | elsif ($r == $COPYRIGHT_NONE) { 41 | say "$module: notice missing"; 42 | $missing ++; 43 | } 44 | else { 45 | say "$module: Huh?"; 46 | } 47 | } 48 | 49 | 50 | if ($count) { 51 | say "Updated copyright notices in $count files."; 52 | } 53 | if ($missing) { 54 | say "Missing copyright notices in $missing files."; 55 | } 56 | if (!$count && !$missing) { 57 | say "All copyright notices are up to date."; 58 | } 59 | 60 | sub find_copyright { 61 | my ($FILE, $YEAR) = @_; 62 | 63 | open my $fh, "<", $FILE; 64 | while (<$fh>) { 65 | if (/Copyright \s+ (?:\(c\) \s+)? (?:2[0-9]{3}) \s*-\s* (2[0-9]{3})/x) { 66 | my $found_year = $1; 67 | if ($found_year == $YEAR) { 68 | return $COPYRIGHT_OK; 69 | } 70 | else { 71 | return $COPYRIGHT_OLD; 72 | } 73 | } 74 | } 75 | return $COPYRIGHT_NONE; 76 | } 77 | 78 | sub fix_copyright { 79 | my ($FILE, $YEAR) = @_; 80 | my @lines; 81 | 82 | open my $fh, "+<", $FILE; 83 | while (<$fh>) { 84 | s{(Copyright \s+ (?:\(c\) \s+)? (?:2[0-9]{3}) \s*-\s* )(2[0-9]{3})} 85 | {$1$year}x; 86 | push @lines => $_; 87 | } 88 | seek $fh, 0, SEEK_SET; 89 | 90 | print $fh @lines; 91 | 92 | close $fh; 93 | } 94 | 95 | __END__ 96 | -------------------------------------------------------------------------------- /t/URI/news.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common; 8 | 9 | $^W = 1; 10 | 11 | 12 | sub create_parts; 13 | 14 | my $news = $RE {URI} {news}; 15 | 16 | my @tests = ( 17 | [news => $news => {news => NORMAL_PASS | FAIL}], 18 | ); 19 | 20 | my ($good, $bad) = create_parts; 21 | 22 | run_tests version => "Regexp::Common::URI::news", 23 | tests => \@tests, 24 | good => $good, 25 | bad => $bad, 26 | query => \&news, 27 | wanted => \&wanted; 28 | 29 | sub news { 30 | my ($tag, $grouppart) = ($_ [0], @{$_ [1]}); 31 | 32 | my $news = "news:"; 33 | $news .= $grouppart if defined $grouppart; 34 | 35 | $news; 36 | } 37 | 38 | sub wanted { 39 | my ($tag, $parts) = @_; 40 | 41 | my @wanted; 42 | $wanted [0] = $_; 43 | $wanted [1] = "news"; 44 | $wanted [2] = $$parts [0]; 45 | 46 | \@wanted; 47 | } 48 | 49 | 50 | sub create_parts { 51 | my (@good, @bad); 52 | 53 | my @good_arts = qw {fnord banzai123 4567 000 (!!make-$$$-fast**) 54 | %00%FF%12''' really? ?/?/?/&=:;}; 55 | my @good_hosts = qw /www.abigail.freedom.nl www.PERL.com a.b.c.d.e.f.g.h.i.j.k.x 56 | 127.0.0.1 w--w--w.abigail.freedom.nl w3.abigail.freedom.nl/; 57 | 58 | my @bad_arts = ("", qw /%GG %F %7- %% {} <> ~abigail []/); 59 | my @bad_hosts = ("", qw /www.example..com w+w.example.com 60 | w--.example.com 127.0.1 127.0.0.0.1 61 | -w.example.com www.example.1com/); 62 | 63 | # Groupparts. 64 | $good [0] = ["*", qw /a comp.lang.perl.misc comp.lang.c++ hello_kitty_ 65 | foo-1234567890/, 66 | map {join '@' => @$_} 67 | t::Common::cross (\@good_arts, \@good_hosts)]; 68 | $bad [0] = ["", qw /1234567890 ** really? (!!make-$$$-fast**) 69 | _hello_kitty_/, 70 | (map {join '@' => @$_} 71 | t::Common::cross (\@good_arts, \@bad_hosts)), 72 | (map {join '@' => @$_} 73 | t::Common::cross (\@bad_arts, \@good_hosts))]; 74 | 75 | return (\@good, \@bad); 76 | } 77 | 78 | 79 | __END__ 80 | -------------------------------------------------------------------------------- /fix_versions: -------------------------------------------------------------------------------- 1 | #!/opt/perl/bin/perl 2 | 3 | use 5.010; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | use autodie; 9 | 10 | use POSIX 'strftime'; 11 | use Fcntl 'SEEK_CUR'; 12 | 13 | sub find; 14 | sub fix; 15 | 16 | my $CHANGES = "Changes"; 17 | my $README = "README"; 18 | my @MODULES = `find lib -type f -name "*.pm"`; 19 | chomp @MODULES; 20 | 21 | my $VERSION = shift; 22 | 23 | die "Illegal version" unless 24 | $VERSION =~ /^(?20[0-9]{2})(?[01][0-9]) 25 | (?[0-3][0-9])(?[0-9][0-9])$/x; 26 | my ($year, $month, $date, $seq) = @+ {qw [year month date seq]}; 27 | 28 | my $TODAY = strftime "%Y%m%d" => localtime; 29 | 30 | die "Will only set versions matching today's date [$TODAY/$year$month$date]" 31 | unless $TODAY eq "$year$month$date"; 32 | die "Will not set a sequence number to 00" if $seq eq "00"; 33 | 34 | unless (find $VERSION, $README, 2) { 35 | say "Going to change $README"; 36 | fix $VERSION, $README, 2; 37 | } 38 | unless (find $VERSION, $CHANGES, 1) { 39 | say "Going to change $CHANGES"; 40 | fix $VERSION, $CHANGES, 1, 1; 41 | } 42 | foreach my $module (@MODULES) { 43 | unless (find $VERSION, $module, "VERSION =") { 44 | say "Going to change $module"; 45 | fix $VERSION, $module, "VERSION ="; 46 | } 47 | } 48 | 49 | 50 | sub find { 51 | my ($VERSION, $FILE, $TARGET) = @_; 52 | 53 | open my $fh, "<", $FILE; 54 | my $line = ""; 55 | if ($TARGET =~ /^[0-9]+$/) { 56 | $line = <$fh> for 1 .. $TARGET; 57 | } 58 | else {{ 59 | $line = <$fh>; 60 | redo unless $line =~ /$TARGET/; 61 | }} 62 | 63 | $line =~ /\b$VERSION\b/; 64 | } 65 | 66 | sub fix { 67 | my ($VERSION, $FILE, $TARGET, $date) = @_; 68 | 69 | open my $fh, "+<", $FILE; 70 | my $line = ""; 71 | if ($TARGET =~ /^[0-9]+$/) { 72 | $line = <$fh> for 1 .. $TARGET; 73 | } 74 | else {{ 75 | $line = <$fh>; 76 | redo unless $line =~ /$TARGET/; 77 | }} 78 | 79 | my $pat = '\b[0-9]{10}\b'; 80 | my $repl = $VERSION; 81 | if ($date) { 82 | $pat .= " .*"; 83 | $repl .= " " . `date`; 84 | chomp $repl; 85 | } 86 | 87 | 88 | if ($line =~ s/$pat/$repl/) { 89 | seek $fh, - length ($line), SEEK_CUR; 90 | print $fh $line; 91 | } 92 | 93 | close $fh; 94 | } 95 | 96 | __END__ 97 | -------------------------------------------------------------------------------- /lib/Regexp/Common/whitespace.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::whitespace; 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Regexp::Common qw /pattern clean no_defaults/; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | pattern name => [qw (ws crop)], 14 | create => '(?:^\s+|\s+$)', 15 | subs => sub {$_[1] =~ s/^\s+//; $_[1] =~ s/\s+$//;} 16 | ; 17 | 18 | 19 | 1; 20 | 21 | __END__ 22 | 23 | =pod 24 | 25 | =head1 NAME 26 | 27 | Regexp::Common::whitespace -- provides a regex for leading or 28 | trailing whitescape 29 | 30 | =head1 SYNOPSIS 31 | 32 | use Regexp::Common qw /whitespace/; 33 | 34 | while (<>) { 35 | s/$RE{ws}{crop}//g; # Delete surrounding whitespace 36 | } 37 | 38 | 39 | =head1 DESCRIPTION 40 | 41 | Please consult the manual of L for a general description 42 | of the works of this interface. 43 | 44 | Do not use this module directly, but load it via I. 45 | 46 | 47 | =head2 C<$RE{ws}{crop}> 48 | 49 | Returns a pattern that identifies leading or trailing whitespace. 50 | 51 | For example: 52 | 53 | $str =~ s/$RE{ws}{crop}//g; # Delete surrounding whitespace 54 | 55 | The call: 56 | 57 | $RE{ws}{crop}->subs($str); 58 | 59 | is optimized (but probably still slower than doing the s///g explicitly). 60 | 61 | This pattern does not capture under C<-keep>. 62 | 63 | =head1 SEE ALSO 64 | 65 | L for a general description of how to use this interface. 66 | 67 | =head1 AUTHOR 68 | 69 | Damian Conway (damian@conway.org) 70 | 71 | =head1 MAINTENANCE 72 | 73 | This package is maintained by Abigail S<(I)>. 74 | 75 | =head1 BUGS AND IRRITATIONS 76 | 77 | Bound to be plenty. 78 | 79 | For a start, there are many common regexes missing. 80 | Send them in to I. 81 | 82 | =head1 LICENSE and COPYRIGHT 83 | 84 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 85 | 86 | This module is free software, and maybe used under any of the following 87 | licenses: 88 | 89 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 90 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 91 | 3) The BSD License. See the file COPYRIGHT.BSD. 92 | 4) The MIT License. See the file COPYRIGHT.MIT. 93 | 94 | =cut 95 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/RFC1035.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::RFC1035; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | our $VERSION = '2024080801'; 9 | 10 | use Exporter (); 11 | our @ISA = qw /Exporter/; 12 | 13 | my %vars; 14 | 15 | BEGIN { 16 | $vars {low} = [qw /$digit $letter $let_dig $let_dig_hyp $ldh_str/]; 17 | $vars {parts} = [qw /$label $subdomain/]; 18 | $vars {domain} = [qw /$domain/]; 19 | } 20 | 21 | our @EXPORT = qw /$host/; 22 | our @EXPORT_OK = map {@$_} values %vars; 23 | our %EXPORT_TAGS = (%vars, ALL => [@EXPORT_OK]); 24 | 25 | # RFC 1035. 26 | our $digit = "[0-9]"; 27 | our $letter = "[A-Za-z]"; 28 | our $let_dig = "[A-Za-z0-9]"; 29 | our $let_dig_hyp = "[-A-Za-z0-9]"; 30 | our $ldh_str = "(?:[-A-Za-z0-9]+)"; 31 | our $label = "(?:$letter(?:(?:$ldh_str){0,61}$let_dig)?)"; 32 | our $subdomain = "(?:$label(?:[.]$label)*)"; 33 | our $domain = "(?: |(?:$subdomain))"; 34 | 35 | 36 | 1; 37 | 38 | __END__ 39 | 40 | =pod 41 | 42 | =head1 NAME 43 | 44 | Regexp::Common::URI::RFC1035 -- Definitions from RFC1035; 45 | 46 | =head1 SYNOPSIS 47 | 48 | use Regexp::Common::URI::RFC1035 qw /:ALL/; 49 | 50 | =head1 DESCRIPTION 51 | 52 | This package exports definitions from RFC1035. It's intended 53 | usage is for Regexp::Common::URI submodules only. Its interface 54 | might change without notice. 55 | 56 | =head1 REFERENCES 57 | 58 | =over 4 59 | 60 | =item B<[RFC 1035]> 61 | 62 | Mockapetris, P.: I. 63 | November 1987. 64 | 65 | =back 66 | 67 | =head1 AUTHOR 68 | 69 | Damian Conway (damian@conway.org) 70 | 71 | =head1 MAINTENANCE 72 | 73 | This package is maintained by Abigail S<(I)>. 74 | 75 | =head1 BUGS AND IRRITATIONS 76 | 77 | Bound to be plenty. 78 | 79 | =head1 LICENSE and COPYRIGHT 80 | 81 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 82 | 83 | This module is free software, and maybe used under any of the following 84 | licenses: 85 | 86 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 87 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 88 | 3) The BSD License. See the file COPYRIGHT.BSD. 89 | 4) The MIT License. See the file COPYRIGHT.MIT. 90 | 91 | =cut 92 | -------------------------------------------------------------------------------- /t/test_i.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Eventually, this should be tested from the individual test files. 4 | 5 | use strict; 6 | use lib qw {blib/lib}; 7 | 8 | use Regexp::Common qw /RE_ALL/; 9 | 10 | use warnings; 11 | 12 | 13 | my @data = ( 14 | [[qw /num hex/] => ["abcdef", "123.456", "1a2B.3c"]], 15 | [[qw /comment ILLGOL/] => ["NB foo bar\n", "nb foo bar\n"]], 16 | [[qw /net domain/] => ["www.perl.com", "WWW.PERL.COM"]], 17 | [[qw /net MAC/] => ["a0:b0:c0:d0:e0:f0", "A0:B0:C0:D0:E0:F0"]], 18 | [[qw /zip Dutch/] => ["1234 ab", "1234 AB", "nl-1234 AB"]], 19 | [[qw /URI HTTP/] => ["HTTP://WWW.PERL.COM"]], 20 | [[qw /profanity/] => [map {local $_ = $_; 21 | y/a-zA-Z/n-za-mN-ZA-M/; $_} qw / 22 | pbpx-fhpxre srygpuvat zhgure-shpxre 23 | zhgun-shpxvat fuvgf fuvgre penccvat 24 | nefr-ubyr cvff-gnxr jnaxf/]], 25 | [[qw /num roman/] => [qw /I i II ii XvIiI CXxxVIiI MmclXXviI/]], 26 | ); 27 | 28 | push @data => ( 29 | [[qw /balanced/] => ["()", "(a( )b)"]], 30 | ); 31 | 32 | my $total = 1; 33 | $total += 2 * @{$_ -> [1]} for @data; 34 | 35 | print "1..$total\n"; 36 | 37 | print defined $Regexp::Common::VERSION ? "ok 1\n" : "not ok 1\n"; 38 | 39 | my $count = 1; 40 | sub pass { 41 | my @a = @_; 42 | $a [0] =~ y/a-zA-Z/n-za-mN-ZA-M/ if $a [1] =~ /profanity/; 43 | $a [0] =~ s/\n/\\n/g; 44 | printf "ok %d - '%s' =~ %s\n", ++ $count, @a 45 | } 46 | sub fail { 47 | my @a = @_; 48 | $a [0] =~ y/a-zA-Z/n-za-mN-ZA-M/ if $a [1] =~ /profanity/; 49 | $a [0] =~ s/\n/\\n/g; 50 | printf "not ok %d - '%s' =~ %s\n", ++ $count, @a 51 | } 52 | 53 | foreach my $data (@data) { 54 | my ($name, $queries) = @$data; 55 | 56 | foreach my $str (@$queries) { 57 | local $" = "}{"; 58 | eval "\$str =~ /^\$RE{@$name}{-i}\$/ 59 | ? pass \$str, '\$RE{@$name}{-i}' 60 | : fail \$str, '\$RE{@$name}{-i}'"; 61 | die $@ if $@; 62 | local $" = "_"; 63 | eval "\$str =~ RE_@$name (-i => 1) 64 | ? pass \$str, 'RE_@$name (-i => 1)', 65 | : fail \$str, 'RE_@$name (-i => 1)'"; 66 | die $@ if $@; 67 | } 68 | } 69 | 70 | 71 | 72 | 73 | __END__ 74 | -------------------------------------------------------------------------------- /t/URI/pop.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common; 8 | 9 | $^W = 1; 10 | $DEBUG = 1; 11 | 12 | 13 | sub create_parts; 14 | 15 | my $scheme = 'pop'; 16 | my $pop = $RE {URI} {uc $scheme}; 17 | 18 | # No point in crosschecking, URI creation is tag independent. 19 | my @tests = ( 20 | [pop => $pop => {pop => NORMAL_PASS | FAIL}], 21 | ); 22 | 23 | my ($good, $bad) = create_parts; 24 | 25 | run_tests version => "Regexp::Common::URI::$scheme", 26 | tests => \@tests, 27 | good => $good, 28 | bad => $bad, 29 | query => \&query, 30 | wanted => \&wanted, 31 | filter => \&filter, 32 | ; 33 | 34 | sub query { 35 | my ($tag, $user, $auth_type, $host, $port) = ($_ [0], @{$_ [1]}); 36 | 37 | my $url = "$scheme://"; 38 | if (defined $user) { 39 | $url .= $user; 40 | $url .= ";AUTH=$auth_type" if defined $auth_type; 41 | $url .= '@'; 42 | } 43 | $url .= $host if defined $host; 44 | $url .= ":$port" if defined $port; 45 | 46 | $url; 47 | } 48 | 49 | sub wanted { 50 | my ($tag, $parts) = @_; 51 | 52 | my @wanted; 53 | $wanted [0] = $_; 54 | $wanted [1] = "$scheme"; 55 | $wanted [2] = $$parts [0]; # user. 56 | $wanted [3] = $$parts [1]; # auth. 57 | $wanted [4] = $$parts [2]; # host. 58 | $wanted [5] = $$parts [3]; # port. 59 | 60 | \@wanted; 61 | } 62 | 63 | 64 | sub create_parts { 65 | my (@good, @bad); 66 | 67 | # Users 68 | $good [0] = [undef, qw /abigail/]; 69 | $bad [0] = ["", qw /abigail%GG [abigail]/]; 70 | 71 | # Auth_type 72 | $good [1] = [undef, qw /* password &~=~& +APOP +password +/]; 73 | $bad [1] = ["", qw /"password" camel-][/]; 74 | 75 | # Hosts. 76 | $good [2] = [qw /pop3.abigail.freedom.nl pop3.PERL.com 127.0.0.1/]; 77 | $bad [2] = [qw /www.example..com w+w.example.com 127.0.0.0.1 78 | w--.example.com -w.example.com www.example.1com/]; 79 | 80 | # Ports. 81 | $good [3] = [undef, 110]; 82 | $bad [3] = ["", qw /: port/]; 83 | 84 | return (\@good, \@bad); 85 | } 86 | 87 | 88 | sub filter { 89 | return 0 if defined ${$_ [0]} [1] && !defined ${$_ [0]} [0]; 90 | 91 | return 1; 92 | } 93 | 94 | 95 | __END__ 96 | -------------------------------------------------------------------------------- /t/SEN/usa_ssn.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common qw /run_new_tests cross criss_cross dd pdd/; 8 | 9 | $^W = 1; 10 | 11 | 12 | my $ssn = $RE {SEN} {USA} {SSN}; 13 | my $space = $ssn -> {-sep => ' '}; 14 | my $empty = $ssn -> {-sep => ''}; 15 | 16 | use constant PASS => 4; 17 | use constant FAIL => 3; 18 | 19 | my $areas = [ "001", map {pdd 3} 1 .. PASS]; 20 | my $groups = [ "01", map {pdd 2} 1 .. PASS]; 21 | my $serials = ["0001", map {pdd 4} 1 .. PASS]; 22 | 23 | my $bad_a = [ "000", "", dd (1), dd (2), dd (4), dd (5, 10)]; 24 | my $bad_g = [ "00", "", dd (1), dd (3), dd (4), dd (5, 10)]; 25 | my $bad_s = ["0000", "", dd (1), dd (2), dd (3), dd (5, 10)]; 26 | 27 | my $ssns = [cross $areas, $groups, $serials]; 28 | my $wrong = [criss_cross [[@$areas [0 .. FAIL - 1]], 29 | [@$groups [0 .. FAIL - 1]], 30 | [@$serials [0 .. FAIL - 1]]], 31 | [$bad_a, $bad_g, $bad_s]]; 32 | 33 | my %targets = ( 34 | ssn => { 35 | list => $ssns, 36 | query => sub {join "-" => @_}, 37 | wanted => sub {$_ => @_}, 38 | }, 39 | space => { 40 | list => $ssns, 41 | query => sub {join " " => @_}, 42 | wanted => sub {$_ => @_}, 43 | }, 44 | empty => { 45 | list => $ssns, 46 | query => sub {join "" => @_}, 47 | wanted => sub {$_ => @_}, 48 | }, 49 | wrong1 => { 50 | list => $wrong, 51 | query => sub {join "-" => @_}, 52 | }, 53 | wrong2 => { 54 | list => $wrong, 55 | query => sub {join " " => @_}, 56 | }, 57 | ); 58 | 59 | my @wrongs = qw /wrong1 wrong2/; 60 | 61 | my @tests = ( 62 | { name => 'basic', 63 | regex => $ssn, 64 | pass => [qw /ssn/], 65 | fail => [qw /empty space/, @wrongs], 66 | }, 67 | { name => 'space', 68 | regex => $space, 69 | pass => [qw /space/], 70 | fail => [qw /empty ssn/, @wrongs], 71 | }, 72 | { name => 'empty', 73 | regex => $empty, 74 | pass => [qw /empty/], 75 | fail => [qw /ssn space/, @wrongs], 76 | }, 77 | ); 78 | 79 | 80 | run_new_tests tests => \@tests, 81 | targets => \%targets, 82 | version_from => 'Regexp::Common::SEN', 83 | ; 84 | 85 | __END__ 86 | -------------------------------------------------------------------------------- /lib/Regexp/Common/_support.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::_support; 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | our $VERSION = '2024080801'; 10 | 11 | # 12 | # Returns true/false, depending whether the given the argument 13 | # satisfies the LUHN checksum. 14 | # See http://www.webopedia.com/TERM/L/Luhn_formula.html. 15 | # 16 | # Note that this function is intended to be called from regular 17 | # expression, so it should NOT use a regular expression in any way. 18 | # 19 | sub luhn { 20 | my $arg = shift; 21 | my $even = 0; 22 | my $sum = 0; 23 | while (length $arg) { 24 | my $num = chop $arg; 25 | return if $num lt '0' || $num gt '9'; 26 | if ($even && (($num *= 2) > 9)) {$num = 1 + ($num % 10)} 27 | $even = 1 - $even; 28 | $sum += $num; 29 | } 30 | !($sum % 10) 31 | } 32 | 33 | sub import { 34 | my $pack = shift; 35 | my $caller = caller; 36 | no strict 'refs'; 37 | *{$caller . "::" . $_} = \&{$pack . "::" . $_} for @_; 38 | } 39 | 40 | 41 | 1; 42 | 43 | __END__ 44 | 45 | =pod 46 | 47 | =head1 NAME 48 | 49 | Regexp::Common::support -- Support functions for Regexp::Common. 50 | 51 | =head1 SYNOPSIS 52 | 53 | use Regexp::Common::_support qw /luhn/; 54 | 55 | luhn ($number) # Returns true/false. 56 | 57 | 58 | =head1 DESCRIPTION 59 | 60 | This module contains some subroutines to be used by other C 61 | modules. It's not intended to be used directly. Subroutines from the 62 | module may disappear without any notice, or their meaning or interface 63 | may change without notice. 64 | 65 | =over 4 66 | 67 | =item luhn 68 | 69 | This subroutine returns true if its argument passes the luhn checksum test. 70 | 71 | =back 72 | 73 | =head1 SEE ALSO 74 | 75 | L. 76 | 77 | =head1 AUTHOR 78 | 79 | Abigail S<(I)>. 80 | 81 | =head1 BUGS AND IRRITATIONS 82 | 83 | Bound to be plenty. 84 | 85 | =head1 LICENSE and COPYRIGHT 86 | 87 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 88 | 89 | This module is free software, and maybe used under any of the following 90 | licenses: 91 | 92 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 93 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 94 | 3) The BSD License. See the file COPYRIGHT.BSD. 95 | 4) The MIT License. See the file COPYRIGHT.MIT. 96 | 97 | =cut 98 | -------------------------------------------------------------------------------- /t/URI/nntp.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common; 8 | 9 | $^W = 1; 10 | 11 | 12 | sub create_parts; 13 | 14 | my $nntp = $RE {URI} {NNTP}; 15 | 16 | my @tests = ( 17 | [nntp => $nntp => {nntp => NORMAL_PASS | FAIL}], 18 | ); 19 | 20 | my ($good, $bad) = create_parts; 21 | 22 | run_tests version => "Regexp::Common::URI::news", 23 | tests => \@tests, 24 | good => $good, 25 | bad => $bad, 26 | query => \&nntp, 27 | wanted => \&wanted; 28 | 29 | sub nntp { 30 | my ($tag, $host, $port, $group, $digits) = ($_ [0], @{$_ [1]}); 31 | 32 | my $nntp = "nntp://"; 33 | $nntp .= $host if defined $host; 34 | $nntp .= ":$port" if defined $port; 35 | $nntp .= "/$group" if defined $group; 36 | $nntp .= "/$digits" if defined $digits; 37 | 38 | $nntp; 39 | } 40 | 41 | sub wanted { 42 | my ($tag, $parts) = @_; 43 | 44 | my @wanted; 45 | $wanted [0] = $_; 46 | $wanted [1] = "nntp"; 47 | $wanted [2] = join "/" => grep {defined} 48 | join (":" => grep {defined} @$parts [0, 1]), 49 | @$parts [2, 3]; 50 | $wanted [3] = join ":" => grep {defined} @$parts [0, 1]; 51 | $wanted [4] = $$parts [0]; 52 | $wanted [5] = $$parts [1]; 53 | $wanted [6] = $$parts [2]; 54 | $wanted [7] = $$parts [3]; 55 | 56 | \@wanted; 57 | } 58 | 59 | 60 | sub create_parts { 61 | my (@good, @bad); 62 | 63 | # Hosts. 64 | $good [0] = [qw /www.abigail.freedom.nl www.PERL.com a.b.c.d.e.f.g.h.i.j.k.x 65 | 127.0.0.1 w--w--w.abigail.freedom.nl w3.abigail.freedom.nl/]; 66 | $bad [0] = [qw /www.example..com w+w.example.com w--.example.com 67 | 127.0.0.0.1 -w.example.com www.example.1com/]; 68 | 69 | # Ports. 70 | $good [1] = [undef, 119]; 71 | $bad [2] = ["", qw /-19 : port/]; 72 | 73 | # Group. 74 | $good [2] = [qw /a comp.lang.perl.misc comp.lang.c++ hello_kitty_ 75 | foo-1234567890/]; 76 | $bad [2] = [undef, "", qw /1234567890 ** really? (!!make-$$$-fast**) 77 | _hello_kitty_/]; 78 | 79 | # Digits. 80 | $good [3] = [undef, qw /0 0000 12345/]; 81 | $bad [3] = ["", qw /fnurd -19 */, "1234/", "/12", "/"]; 82 | 83 | return (\@good, \@bad); 84 | } 85 | 86 | 87 | __END__ 88 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/tv.pm: -------------------------------------------------------------------------------- 1 | # TV URLs. 2 | # Internet draft: draft-zigmond-tv-url-03.txt 3 | 4 | package Regexp::Common::URI::tv; 5 | 6 | use Regexp::Common qw /pattern clean no_defaults/; 7 | use Regexp::Common::URI qw /register_uri/; 8 | use Regexp::Common::URI::RFC2396 qw /$hostname/; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | our $VERSION = '2024080801'; 14 | 15 | 16 | my $tv_scheme = 'tv'; 17 | my $tv_url = "(?k:(?k:$tv_scheme):(?k:$hostname)?)"; 18 | 19 | register_uri $tv_scheme => $tv_url; 20 | 21 | pattern name => [qw (URI tv)], 22 | create => $tv_url, 23 | ; 24 | 25 | 1; 26 | 27 | __END__ 28 | 29 | =pod 30 | 31 | =head1 NAME 32 | 33 | Regexp::Common::URI::tv -- Returns a pattern for tv URIs. 34 | 35 | =head1 SYNOPSIS 36 | 37 | use Regexp::Common qw /URI/; 38 | 39 | while (<>) { 40 | /$RE{URI}{tv}/ and print "Contains a tv URI.\n"; 41 | } 42 | 43 | =head1 DESCRIPTION 44 | 45 | =head2 C<$RE{URI}{tv}> 46 | 47 | Returns a pattern that recognizes TV uris as per an Internet draft 48 | [DRAFT-URI-TV]. 49 | 50 | Under C<{-keep}>, the following are returned: 51 | 52 | =over 4 53 | 54 | =item $1 55 | 56 | The entire URI. 57 | 58 | =item $2 59 | 60 | The scheme. 61 | 62 | =item $3 63 | 64 | The host. 65 | 66 | =back 67 | 68 | =head1 REFERENCES 69 | 70 | =over 4 71 | 72 | =item B<[DRAFT-URI-TV]> 73 | 74 | Zigmond, D. and Vickers, M: I. December 2000. 76 | 77 | =item B<[RFC 2396]> 78 | 79 | Berners-Lee, Tim, Fielding, R., and Masinter, L.: I. August 1998. 81 | 82 | =back 83 | 84 | =head1 SEE ALSO 85 | 86 | L for other supported URIs. 87 | 88 | =head1 AUTHOR 89 | 90 | Damian Conway (damian@conway.org) 91 | 92 | =head1 MAINTENANCE 93 | 94 | This package is maintained by Abigail S<(I)>. 95 | 96 | =head1 BUGS AND IRRITATIONS 97 | 98 | Bound to be plenty. 99 | 100 | =head1 LICENSE and COPYRIGHT 101 | 102 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 103 | 104 | This module is free software, and maybe used under any of the following 105 | licenses: 106 | 107 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 108 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 109 | 3) The BSD License. See the file COPYRIGHT.BSD. 110 | 4) The MIT License. See the file COPYRIGHT.MIT. 111 | 112 | =cut 113 | -------------------------------------------------------------------------------- /t/zip/zip.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}; 5 | 6 | use Regexp::Common; 7 | use warnings; 8 | 9 | 10 | my @tests__ = ("", "\n", "hello, world"); 11 | 12 | my %tests_t = ( 13 | "{1,1}" => [qw [y yes Y YES YeLLow]], 14 | "{0,0}" => [qw [n no N NO Nano]], 15 | "{0,1}" => [qw [R blue maroon], "\n", "", " ", undef, "\nn"], 16 | ); 17 | 18 | # 19 | # Cut and paste from Regexp::Common::zip 20 | # 21 | my %code = ( 22 | Austria => [qw /AU?T AT AUT/], 23 | Australia => [qw /AUS? AU AUS/], 24 | Belgium => [qw /BE? BE B/], 25 | Denmark => [qw /DK DK DK/], 26 | France => [qw /FR? FR F/], 27 | Germany => [qw /DE? DE D/], 28 | Greenland => [qw /GL GL GL/], 29 | Italy => [qw /IT? IT I/], 30 | Netherlands => [qw /NL NL NL/], 31 | Norway => [qw /NO? NO N/], 32 | Spain => [qw /ES? ES E/], 33 | USA => [qw /USA? US USA/], 34 | ); 35 | 36 | my $tests = @tests__ + 2; 37 | $tests += @$_ for values %tests_t; 38 | $tests += 1; 39 | $tests += keys %code; 40 | 41 | print "1..$tests\n"; 42 | 43 | my $count = 0; 44 | 45 | # 46 | # Test the __ subroutine. 47 | # 48 | 49 | foreach my $test (@tests__) { 50 | my $ret = Regexp::Common::zip::__ $test; 51 | printf "%s %d\n" => defined $ret && $ret eq $test ? "ok" : "not ok", 52 | ++ $count; 53 | } 54 | 55 | my $ret1 = Regexp::Common::zip::__ undef; 56 | my $ret2 = Regexp::Common::zip::__; 57 | printf "%s %d\n" => defined $ret1 && $ret1 eq "" ? "ok" : "not ok", ++ $count; 58 | printf "%s %d\n" => defined $ret2 && $ret2 eq "" ? "ok" : "not ok", ++ $count; 59 | 60 | # 61 | # Test the _t subroutine 62 | # 63 | while (my ($ret, $tests) = each %tests_t) { 64 | foreach my $test (@$tests) { 65 | my $r = Regexp::Common::zip::_t $test; 66 | printf "%s %d\n" => defined $r && $r eq $ret ? "ok" : "not ok", 67 | ++ $count; 68 | } 69 | } 70 | my $r = Regexp::Common::zip::_t; 71 | printf "%s %d\n" => defined $r && $r eq "{0,1}" ? "ok" : "not ok", 72 | ++ $count; 73 | 74 | 75 | # 76 | # Test the _c subroutine - we don't have to test all the possible 77 | # returned values - that's already done from the various country 78 | # specific tests. In fact, all we need to test is giving an 79 | # undefined second parameter. 80 | # 81 | 82 | while (my ($name, $codes) = each %code) { 83 | my $r = Regexp::Common::zip::_c $name; 84 | 85 | printf "%s %d\n" => defined $r && $r eq $$codes [0] ? "ok" : "not ok", 86 | ++ $count; 87 | } 88 | 89 | 90 | __END__ 91 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/pop.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::pop; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC1738 qw /$host $port/; 6 | use Regexp::Common::URI::RFC2384 qw /$enc_user $enc_auth_type/; 7 | 8 | use strict; 9 | use warnings; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | 14 | my $scheme = "pop"; 15 | my $uri = "(?k:(?k:$scheme)://(?:(?k:$enc_user)" . 16 | "(?:;AUTH=(?k:[*]|$enc_auth_type))?\@)?" . 17 | "(?k:$host)(?::(?k:$port))?)"; 18 | 19 | register_uri $scheme => $uri; 20 | 21 | pattern name => [qw (URI POP)], 22 | create => $uri, 23 | ; 24 | 25 | 1; 26 | 27 | __END__ 28 | 29 | =pod 30 | 31 | =head1 NAME 32 | 33 | Regexp::Common::URI::pop -- Returns a pattern for POP URIs. 34 | 35 | =head1 SYNOPSIS 36 | 37 | use Regexp::Common qw /URI/; 38 | 39 | while (<>) { 40 | /$RE{URI}{POP}/ and print "Contains a POP URI.\n"; 41 | } 42 | 43 | =head1 DESCRIPTION 44 | 45 | =head2 $RE{URI}{POP} 46 | 47 | Returns a pattern that matches I URIs, as defined by RFC 2384. 48 | POP URIs have the form: 49 | 50 | "pop:" "//" [ user [ ";AUTH" ( "*" | auth_type ) ] "@" ] 51 | host [ ":" port ] 52 | 53 | Under C<{-keep}>, the following are returned: 54 | 55 | =over 4 56 | 57 | =item $1 58 | 59 | The complete URI. 60 | 61 | =item $2 62 | 63 | The I. 64 | 65 | =item $3 66 | 67 | The I, if given. 68 | 69 | =item $4 70 | 71 | The I, if given (could be a I<*>). 72 | 73 | =item $5 74 | 75 | The I. 76 | 77 | =item $6 78 | 79 | The I, if given. 80 | 81 | =back 82 | 83 | =head1 REFERENCES 84 | 85 | =over 4 86 | 87 | =item B<[RFC 2384]> 88 | 89 | Gellens, R.: I. August 1998. 90 | 91 | =back 92 | 93 | =head1 SEE ALSO 94 | 95 | L for other supported URIs. 96 | 97 | =head1 AUTHOR 98 | 99 | Abigail. (I). 100 | 101 | =head1 BUGS AND IRRITATIONS 102 | 103 | Bound to be plenty. 104 | 105 | =head1 LICENSE and COPYRIGHT 106 | 107 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 108 | 109 | This module is free software, and maybe used under any of the following 110 | licenses: 111 | 112 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 113 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 114 | 3) The BSD License. See the file COPYRIGHT.BSD. 115 | 4) The MIT License. See the file COPYRIGHT.MIT. 116 | 117 | =cut 118 | -------------------------------------------------------------------------------- /t/zzz_author_tests/120_versions.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Test::More; 10 | 11 | 12 | sub version; 13 | 14 | # 15 | # For a minute or two, I considered using File::Find. 16 | # 17 | # Henry Spencer was right: 18 | # 19 | # "Those who don't understand Unix are condemned to reinvent it, poorly." 20 | # 21 | 22 | undef $ENV {PATH}; 23 | my $FIND = "/usr/bin/find"; 24 | 25 | my $top = -d "blib" ? "blib/lib" : "lib"; 26 | my @files = `$FIND $top -name [a-zA-Z_]*.pm`; 27 | chomp @files; 28 | 29 | say "$top/Regexp/Common.pm"; 30 | 31 | my $main_version = version "$top/Regexp/Common.pm"; 32 | unless ($main_version) { 33 | fail "Cannot find a version in main file"; 34 | done_testing; 35 | exit; 36 | } 37 | 38 | pass "Got a VERSION declaration in main file"; 39 | 40 | foreach my $file (@files, "README") { 41 | my $base = $file; 42 | $base =~ s!^.*/!!; 43 | # 44 | # Grab version 45 | # 46 | my $version = version $file; 47 | 48 | unless ($version) { 49 | fail "Did not find a version in $base; skipping tests"; 50 | next; 51 | } 52 | 53 | pass "Found version $version in $base"; 54 | 55 | if ($version eq $main_version) { 56 | is $version, $main_version, "Version in $base matches package version" 57 | } 58 | } 59 | 60 | my %monthmap = qw [Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06 61 | Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12]; 62 | 63 | if (open my $fh, "<", "Changes") { 64 | my $first = <$fh>; 65 | if ($first =~ 66 | /^Version ([0-9]{10}) \S+ (\S+) +([0-9]{0,2}) \S+ \S+ ([0-9]{4})/) { 67 | my ($version, $month, $date, $year) = ($1, $2, $3, $4); 68 | pass "Version line in Changes file formatted ok"; 69 | my $target = sprintf "%04d%02d%02d" => $year, $monthmap {$month}, $date; 70 | is substr ($version, 0, 8), $target => " Version and date match"; 71 | is $version, $main_version => " Version matches package version"; 72 | } 73 | else { 74 | SKIP: { 75 | fail "First line of Changes files correctly formatted: $first"; 76 | skip "Cannot extract a correctly formatted version", 2; 77 | }} 78 | } 79 | else { 80 | SKIP: { 81 | fail "Failed to open Changes file: $!"; 82 | skip "Cannot open Changes file", 2; 83 | }} 84 | 85 | done_testing; 86 | 87 | sub version { 88 | my $file = shift; 89 | open my $fh, "<", $file or return; 90 | while (<$fh>) { 91 | return $1 if /^(?:our )?\$VERSION = '([0-9]{10})';$/; 92 | return $1 if /Release of version ([0-9]{10}) /; # README 93 | } 94 | return; 95 | } 96 | 97 | 98 | __END__ 99 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/file.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::file; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC1738 qw /$host $fpath/; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | our $VERSION = '2024080801'; 11 | 12 | 13 | my $scheme = 'file'; 14 | my $uri = "(?k:(?k:$scheme)://(?k:(?k:(?:$host|localhost)?)" . 15 | "(?k:/(?k:$fpath))))"; 16 | 17 | register_uri $scheme => $uri; 18 | 19 | pattern name => [qw (URI file)], 20 | create => $uri, 21 | ; 22 | 23 | 1; 24 | 25 | __END__ 26 | 27 | =pod 28 | 29 | =head1 NAME 30 | 31 | Regexp::Common::URI::file -- Returns a pattern for file URIs. 32 | 33 | =head1 SYNOPSIS 34 | 35 | use Regexp::Common qw /URI/; 36 | 37 | while (<>) { 38 | /$RE{URI}{file}/ and print "Contains a file URI.\n"; 39 | } 40 | 41 | =head1 DESCRIPTION 42 | 43 | =head2 $RE{URI}{file} 44 | 45 | Returns a pattern that matches I URIs, as defined by RFC 1738. 46 | File URIs have the form: 47 | 48 | "file:" "//" [ host | "localhost" ] "/" fpath 49 | 50 | Under C<{-keep}>, the following are returned: 51 | 52 | =over 4 53 | 54 | =item $1 55 | 56 | The complete URI. 57 | 58 | =item $2 59 | 60 | The scheme. 61 | 62 | =item $3 63 | 64 | The part of the URI following "file://". 65 | 66 | =item $4 67 | 68 | The hostname. 69 | 70 | =item $5 71 | 72 | The path name, including the leading slash. 73 | 74 | =item $6 75 | 76 | The path name, without the leading slash. 77 | 78 | =back 79 | 80 | =head1 REFERENCES 81 | 82 | =over 4 83 | 84 | =item B<[RFC 1738]> 85 | 86 | Berners-Lee, Tim, Masinter, L., McCahill, M.: I. December 1994. 88 | 89 | =back 90 | 91 | =head1 SEE ALSO 92 | 93 | L for other supported URIs. 94 | 95 | =head1 AUTHOR 96 | 97 | Damian Conway (damian@conway.org) 98 | 99 | =head1 MAINTENANCE 100 | 101 | This package is maintained by Abigail S<(I)>. 102 | 103 | =head1 BUGS AND IRRITATIONS 104 | 105 | Bound to be plenty. 106 | 107 | =head1 LICENSE and COPYRIGHT 108 | 109 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 110 | 111 | This module is free software, and maybe used under any of the following 112 | licenses: 113 | 114 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 115 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 116 | 3) The BSD License. See the file COPYRIGHT.BSD. 117 | 4) The MIT License. See the file COPYRIGHT.MIT. 118 | 119 | =cut 120 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/RFC2384.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::RFC2384; 2 | 3 | 4 | use Regexp::Common qw /pattern clean no_defaults/; 5 | use Regexp::Common::URI::RFC1738 qw /$unreserved_range $escape $hostport/; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | our $VERSION = '2024080801'; 11 | 12 | 13 | use Exporter (); 14 | our @ISA = qw /Exporter/; 15 | 16 | 17 | my %vars; 18 | 19 | BEGIN { 20 | $vars {low} = [qw /$achar_range $achar $achars $achar_more/]; 21 | $vars {connect} = [qw /$enc_sasl $enc_user $enc_ext $enc_auth_type $auth 22 | $user_auth $server/]; 23 | $vars {parts} = [qw /$pop_url/]; 24 | } 25 | 26 | our @EXPORT = qw /$host/; 27 | our @EXPORT_OK = map {@$_} values %vars; 28 | our %EXPORT_TAGS = (%vars, ALL => [@EXPORT_OK]); 29 | 30 | # RFC 2384, POP3. 31 | 32 | # Lowlevel definitions. 33 | our $achar_range = "$unreserved_range&=~"; 34 | our $achar = "(?:[$achar_range]|$escape)"; 35 | our $achars = "(?:(?:[$achar_range]+|$escape)*)"; 36 | our $achar_more = "(?:(?:[$achar_range]+|$escape)+)"; 37 | our $enc_sasl = $achar_more; 38 | our $enc_user = $achar_more; 39 | our $enc_ext = "(?:[+](?:APOP|$achar_more))"; 40 | our $enc_auth_type = "(?:$enc_sasl|$enc_ext)"; 41 | our $auth = "(?:;AUTH=(?:[*]|$enc_auth_type))"; 42 | our $user_auth = "(?:$enc_user$auth?)"; 43 | our $server = "(?:(?:$user_auth\@)?$hostport)"; 44 | our $pop_url = "(?:pop://$server)"; 45 | 46 | 47 | 1; 48 | 49 | __END__ 50 | 51 | =pod 52 | 53 | =head1 NAME 54 | 55 | Regexp::Common::URI::RFC2384 -- Definitions from RFC2384; 56 | 57 | =head1 SYNOPSIS 58 | 59 | use Regexp::Common::URI::RFC2384 qw /:ALL/; 60 | 61 | =head1 DESCRIPTION 62 | 63 | This package exports definitions from RFC2384. It's intended 64 | usage is for Regexp::Common::URI submodules only. Its interface 65 | might change without notice. 66 | 67 | =head1 REFERENCES 68 | 69 | =over 4 70 | 71 | =item B<[RFC 2384]> 72 | 73 | Gellens, R.: I August 1998. 74 | 75 | =back 76 | 77 | =head1 AUTHOR 78 | 79 | Abigail S<(I)>. 80 | 81 | =head1 BUGS AND IRRITATIONS 82 | 83 | Bound to be plenty. 84 | 85 | =head1 LICENSE and COPYRIGHT 86 | 87 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 88 | 89 | This module is free software, and maybe used under any of the following 90 | licenses: 91 | 92 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 93 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 94 | 3) The BSD License. See the file COPYRIGHT.BSD. 95 | 4) The MIT License. See the file COPYRIGHT.MIT. 96 | 97 | =cut 98 | -------------------------------------------------------------------------------- /t/net/101_ipv4.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | # sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | sub try { 7 | $P = qr /^$_[0]/ 8 | } 9 | sub pass { 10 | ok ($_ [0] =~ $P && $& eq $_ [0]) 11 | } 12 | sub fail { 13 | ok ($_ [0] !~ $P || $& ne $_ [0]) 14 | } 15 | 16 | # LOAD 17 | 18 | use Regexp::Common; 19 | ok; 20 | 21 | # DOTTED DECIMAL 22 | 23 | try $RE{net}{IPv4}; 24 | 25 | pass '0.0.0.0'; 26 | pass '1.1.1.1'; 27 | pass '255.255.255.255'; 28 | pass '255.0.128.23'; 29 | fail '256.0.128.23'; 30 | fail '255.0.1287.23'; 31 | fail '255.a.127.23'; 32 | fail '255 0 127 23'; 33 | fail '255,0,127,23'; 34 | fail '255012723'; 35 | 36 | 37 | try $RE{net}{IPv4}{dec}; 38 | 39 | pass '0.0.0.0'; 40 | pass '1.1.1.1'; 41 | pass '255.255.255.255'; 42 | pass '255.0.128.23'; 43 | fail '256.0.128.23'; 44 | fail '255.0.1287.23'; 45 | fail '255.a.127.23'; 46 | fail '255 0 127 23'; 47 | fail '255,0,127,23'; 48 | fail '255012723'; 49 | 50 | 51 | # DOTTED HEXADECIMAL # 52 | 53 | try $RE{net}{IPv4}{hex}; 54 | 55 | pass '0.0.0.0'; 56 | pass '1.1.1.1'; 57 | pass '55.55.25.5'; 58 | pass '7A.B4.2C.D'; 59 | pass 'FF.FF.FF.FF'; 60 | fail 'FF.FF.FF.1FF'; 61 | fail '255.0.1287.23'; 62 | fail '255.a.127.23'; 63 | fail '255 0 127 23'; 64 | fail '255,0,127,23'; 65 | fail '255012723'; 66 | 67 | try $RE{net}{IPv4}{hex}{-sep=>""}; 68 | 69 | fail '0.0.0.0'; 70 | fail '1.1.1.1'; 71 | pass '55552505'; 72 | pass '7AB42CD'; 73 | pass 'FFFFFFFF'; 74 | fail 'FFFFFF1FF'; 75 | fail '55 55 25 05'; 76 | fail '7A B4 2C D'; 77 | fail 'FF FF FF FF'; 78 | fail 'FF FF FF 1FF'; 79 | 80 | try $RE{net}{IPv4}{hex}{-sep=>" "}; 81 | 82 | fail '0.0.0.0'; 83 | fail '1.1.1.1'; 84 | fail '55552505'; 85 | fail '7AB42CD'; 86 | fail 'FFFFFFFF'; 87 | fail 'FFFFFF1FF'; 88 | pass '55 55 25 05'; 89 | pass '7A B4 2C D'; 90 | pass 'FF FF FF FF'; 91 | fail 'FF FF FF 1FF'; 92 | 93 | 94 | # DOTTED OCTAL # 95 | 96 | try $RE{net}{IPv4}{oct}; 97 | 98 | pass '0.0.0.0'; 99 | pass '1.1.1.1'; 100 | pass '55.55.25.5'; 101 | fail '7A.B4.2C.D'; 102 | pass '377.377.377.377'; 103 | fail '400.400.400.400'; 104 | fail '377.377.377.1377'; 105 | fail '255.a.127.23'; 106 | fail '255 0 127 23'; 107 | fail '255,0,127,23'; 108 | fail '255012723'; 109 | 110 | 111 | # DOTTED BINARY # 112 | 113 | try $RE{net}{IPv4}{bin}; 114 | 115 | pass '0.0.0.0'; 116 | pass '1.1.1.1'; 117 | pass '101010.101011.1.10000000'; 118 | fail '12.01.01.01'; 119 | fail '101010101.101011.1.10000000'; 120 | fail '10101010-101011-1-10000000'; 121 | fail '10101010101011110000000'; 122 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/prospero.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::prospero; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC1738 qw /$host $port $ppath $fieldname $fieldvalue 6 | $fieldspec/; 7 | 8 | use strict; 9 | use warnings; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | 14 | my $scheme = 'prospero'; 15 | my $uri = "(?k:(?k:$scheme)://(?k:$host)(?::(?k:$port))?" . 16 | "/(?k:$ppath)(?k:$fieldspec*))"; 17 | 18 | register_uri $scheme => $uri; 19 | 20 | pattern name => [qw (URI prospero)], 21 | create => $uri, 22 | ; 23 | 24 | 1; 25 | 26 | __END__ 27 | 28 | =pod 29 | 30 | =head1 NAME 31 | 32 | Regexp::Common::URI::prospero -- Returns a pattern for prospero URIs. 33 | 34 | =head1 SYNOPSIS 35 | 36 | use Regexp::Common qw /URI/; 37 | 38 | while (<>) { 39 | /$RE{URI}{prospero}/ and print "Contains a prospero URI.\n"; 40 | } 41 | 42 | =head1 DESCRIPTION 43 | 44 | =head2 $RE{URI}{prospero} 45 | 46 | Returns a pattern that matches I URIs, as defined by RFC 1738. 47 | prospero URIs have the form: 48 | 49 | "prospero:" "//" host [ ":" port ] "/" path [ fieldspec ] * 50 | 51 | Under C<{-keep}>, the following are returned: 52 | 53 | =over 4 54 | 55 | =item $1 56 | 57 | The complete URI. 58 | 59 | =item $2 60 | 61 | The I. 62 | 63 | =item $3 64 | 65 | The I. 66 | 67 | =item $4 68 | 69 | The I, if given. 70 | 71 | =item $5 72 | 73 | The propero path. 74 | 75 | =item $6 76 | 77 | The field specifications, if given. There can be more field specifications; 78 | they will all be returned in C<$6>. 79 | 80 | =back 81 | 82 | =head1 REFERENCES 83 | 84 | =over 4 85 | 86 | =item B<[RFC 1738]> 87 | 88 | Berners-Lee, Tim, Masinter, L., McCahill, M.: I. December 1994. 90 | 91 | =back 92 | 93 | =head1 SEE ALSO 94 | 95 | L for other supported URIs. 96 | 97 | =head1 AUTHOR 98 | 99 | Abigail. (I). 100 | 101 | =head1 BUGS AND IRRITATIONS 102 | 103 | Bound to be plenty. 104 | 105 | =head1 LICENSE and COPYRIGHT 106 | 107 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 108 | 109 | This module is free software, and maybe used under any of the following 110 | licenses: 111 | 112 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 113 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 114 | 3) The BSD License. See the file COPYRIGHT.BSD. 115 | 4) The MIT License. See the file COPYRIGHT.MIT. 116 | 117 | =cut 118 | -------------------------------------------------------------------------------- /t/comment/html.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib "blib/lib", "."; 5 | 6 | use Regexp::Common qw /RE_comment_HTML/; 7 | use t::Common qw /run_new_tests cross/; 8 | 9 | 10 | use warnings; 11 | 12 | 13 | my @good = ("", "This is a comment", "This is - a comment", 14 | "This is - - comment", ">This is a comment", 15 | ">This is a comment<", "This is comment", 16 | ">", "<>", "><", "<"); 17 | my @spec = ("", ">", "->", " [0], ss, $_ -> [1], ss, $_ -> [2], ss]} 26 | cross \@spec, \@spec, \@spec; 27 | 28 | # Targets, and test suites. 29 | my %targets; 30 | my @tests; 31 | 32 | $targets {simple} = { 33 | list => \@good, 34 | query => sub {""}, 35 | wanted => sub {$_, ""}, 36 | }; 37 | 38 | $targets {simple_space} = { 39 | list => \@spaced, 40 | query => sub {""}, 47 | wanted => sub {$_, ""}, 48 | }; 49 | 50 | $targets {crossed2} = { 51 | list => \@cross3, 52 | query => sub {"", # Missing ! 59 | "", # Not enough dashes, 60 | "", # Too many starting dashes. 62 | "", # Space after ", # Garbage after comment 64 | )} @good; 65 | 66 | $targets {bad1} = { 67 | list => \@bad, 68 | }; 69 | $targets {bad2} = { 70 | list => \@crossed, 71 | query => sub {""}, 72 | }; 73 | 74 | push @tests => { 75 | name => 'HTML', 76 | regex => $RE {comment} {HTML}, 77 | pass => [qw /simple simple_space crossed crossed2/], 78 | fail => [qw /bad1 bad2/], 79 | sub => \&RE_comment_HTML, 80 | }; 81 | 82 | 83 | run_new_tests tests => \@tests, 84 | targets => \%targets, 85 | version_from => 'Regexp::Common::comment', 86 | ; 87 | 88 | 89 | __END__ 90 | -------------------------------------------------------------------------------- /lib/Regexp/Common/lingua.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::lingua; 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Regexp::Common qw /pattern clean no_defaults/; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | 14 | pattern name => [qw /lingua palindrome -chars=[A-Za-z]/], 15 | create => sub { 16 | use re 'eval'; 17 | my $keep = exists $_ [1] -> {-keep}; 18 | my $ch = $_ [1] -> {-chars}; 19 | my $idx = $keep ? "1:$ch" : "0:$ch"; 20 | my $r = "(??{\$Regexp::Common::lingua::pd{'" . $idx . "'}})"; 21 | $Regexp::Common::lingua::pd {$idx} = 22 | $keep ? qr /($ch|($ch)($r)?\2)/ : qr /$ch|($ch)($r)?\1/; 23 | # print "[$ch]: ", $Regexp::Common::lingua::pd {$idx}, "\n"; 24 | # $Regexp::Common::lingua::pd {$idx}; 25 | }, 26 | ; 27 | 28 | 29 | 1; 30 | 31 | __END__ 32 | 33 | =pod 34 | 35 | =head1 NAME 36 | 37 | Regexp::Common::lingua -- provide regexes for language related stuff. 38 | 39 | =head1 SYNOPSIS 40 | 41 | use Regexp::Common qw /lingua/; 42 | 43 | while (<>) { 44 | /^$RE{lingua}{palindrome}$/ and print "is a palindrome\n"; 45 | } 46 | 47 | 48 | =head1 DESCRIPTION 49 | 50 | Please consult the manual of L for a general description 51 | of the works of this interface. 52 | 53 | Do not use this module directly, but load it via I. 54 | 55 | =head2 C<$RE{lingua}{palindrome}> 56 | 57 | Returns a pattern that recognizes a palindrome, a string that is the 58 | same if you reverse it. By default, it only matches strings consisting 59 | of letters, but this can be changed using the C<{-chars}> option. 60 | This option takes a character class (default is C<[A-Za-z]>) as 61 | argument. 62 | 63 | If C<{-keep}> is used, only C<$1> will be set, and set to the entire 64 | match. 65 | 66 | This pattern requires at least perl 5.6.0. 67 | 68 | =head1 SEE ALSO 69 | 70 | L for a general description of how to use this interface. 71 | 72 | =head1 AUTHOR 73 | 74 | Damian Conway (damian@conway.org) 75 | 76 | =head1 MAINTENANCE 77 | 78 | This package is maintained by Abigail S<(I)>. 79 | 80 | =head1 BUGS AND IRRITATIONS 81 | 82 | Many regexes are missing. 83 | Send them in to I. 84 | 85 | =head1 LICENSE and COPYRIGHT 86 | 87 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 88 | 89 | This module is free software, and maybe used under any of the following 90 | licenses: 91 | 92 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 93 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 94 | 3) The BSD License. See the file COPYRIGHT.BSD. 95 | 4) The MIT License. See the file COPYRIGHT.MIT. 96 | 97 | =cut 98 | -------------------------------------------------------------------------------- /t/URI/telnet.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common; 8 | 9 | $^W = 1; 10 | 11 | 12 | sub create_parts; 13 | 14 | my $telnet = $RE {URI} {telnet}; 15 | 16 | my @tests = ( 17 | [telnet => $telnet => {telnet => NORMAL_PASS | FAIL}] 18 | ); 19 | 20 | my ($good, $bad) = create_parts; 21 | 22 | run_tests version => "Regexp::Common::URI", 23 | tests => \@tests, 24 | good => $good, 25 | bad => $bad, 26 | query => \&uri, 27 | wanted => \&wanted, 28 | filter => \&filter; 29 | 30 | 31 | sub uri { 32 | my ($scheme, $user, $password, $host, $port, $slash) = ($_ [0], @{$_ [1]}); 33 | 34 | my $uri = "$scheme://"; 35 | $uri .= $user if defined $user; 36 | $uri .= ":$password" if defined $user && defined $password; 37 | $uri .= '@' if defined $user; 38 | $uri .= $host; 39 | $uri .= ":$port" if defined $port; 40 | $uri .= $slash if defined $slash; 41 | 42 | $uri; 43 | } 44 | 45 | 46 | sub wanted { 47 | my ($scheme, $parts) = @_; 48 | my @wanted; 49 | $wanted [0] = $_; 50 | $wanted [1] = $scheme; 51 | if (defined $$parts [0]) { 52 | $wanted [2] = $$parts [0]; 53 | $wanted [3] = $$parts [0]; 54 | if (defined $$parts [1]) { 55 | $wanted [2] .= ":$$parts[1]"; 56 | $wanted [4] = $$parts [1]; 57 | } 58 | } 59 | $wanted [5] = $$parts [2]; 60 | $wanted [6] = $$parts [2]; 61 | if (defined $$parts [3]) { 62 | $wanted [5] .= ":$$parts[3]"; 63 | $wanted [7] = $$parts [3]; 64 | } 65 | $wanted [8] = undef; 66 | $wanted [8] = "/" if $$parts [4]; 67 | 68 | \@wanted; 69 | } 70 | 71 | 72 | 73 | sub create_parts { 74 | my (@good, @bad); 75 | 76 | # Users. 77 | $good [0] = [undef, "", qw /abigail ab?ga?l; abi%67ai%6C/]; 78 | $bad [0] = [qw /abigail-][/]; 79 | 80 | # Passwords. 81 | $good [1] = [undef, "", qw /secret se??et se%FFret/]; 82 | $bad [1] = [qw /se{}cret/]; 83 | 84 | # Hosts. 85 | $good [2] = [qw /www.abigail.freedom.nl www.PERL.com 127.0.0.1 w3.abigail.freedom.nl/]; 86 | $bad [2] = [qw /www.example..com w+w.example.com w--.example.com 87 | 127.0.0.0.1 -w.example.com www.example.1com/]; 88 | 89 | # Ports. 90 | $good [3] = [undef, 123]; 91 | $bad [3] = ["", qw /-19 : port/]; 92 | 93 | # Trailing /. 94 | $good [4] = [undef, '/']; 95 | $bad [4] = ['//', '/foo', '@']; 96 | 97 | (\@good, \@bad); 98 | } 99 | 100 | 101 | sub filter { 102 | return !defined $_ [0] -> [0] && defined $_ [0] -> [1] ? 0 : 1 103 | } 104 | 105 | __END__ 106 | -------------------------------------------------------------------------------- /t/comment/pascal.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib "blib/lib", "."; 5 | 6 | use Regexp::Common qw /RE_comment_Pascal/; 7 | use t::Common qw /run_new_tests/; 8 | 9 | use warnings; 10 | 11 | 12 | my @open = qw [{ (*]; 13 | my @close = qw [} *)]; 14 | 15 | 16 | # 17 | # Some basic comments, not including delimiters. 18 | # 19 | my @comments = ("", "This is a comment", "This is a\nmultiline comment", 20 | "\n", "*", "\n*\n", "**", "*****", "** **", "/*", "||"); 21 | 22 | # Targets, and test suites. 23 | my %targets; 24 | my @tests; 25 | 26 | foreach my $start (@open) { 27 | foreach my $end (@close) { 28 | my $lang = "Pascal"; 29 | my $pass_key = "pass_${start}_${end}"; 30 | my $fail_key = "fail_${start}_${end}"; 31 | 32 | $targets {$pass_key} = { 33 | list => \@comments, 34 | query => sub {$start . $_ [0] . $end}, 35 | wanted => sub {$_, $start, $_ [0], $end}, 36 | }; 37 | 38 | # Create bad comments. 39 | my @bad_comments; 40 | # No terminating token. 41 | push @bad_comments => map {"$start$_"} @comments; 42 | # No starting token. 43 | push @bad_comments => map {"$_$end"} 44 | grep {index ($_, $start)} @comments; 45 | # Double terminators. 46 | push @bad_comments => map {"$start$_$end$end"} @comments; 47 | # Double the comment. 48 | push @bad_comments => map {"$start$_$end" x 2} @comments; 49 | # Different token. 50 | my @bad_open = qw [// /* --]; 51 | my @bad_close = (qw [*/ --], "\n"); 52 | 53 | foreach my $close (@close) { 54 | push @bad_comments => 55 | map {my $o = $_; map {"ot$_$close"} @comments} @bad_open; 56 | } 57 | foreach my $open (@open) { 58 | push @bad_comments => 59 | map {my $c = $_; map {"$open$_$c"} @comments} @bad_close; 60 | } 61 | 62 | # No tokens. 63 | push @bad_comments => @comments; 64 | 65 | # Text preceeding comment. 66 | push @bad_comments => map {"Text $start$_$end"} @comments; 67 | # Some more. 68 | push @bad_comments => ""; 69 | push @bad_comments => "/* This is a C comment */"; 70 | 71 | $targets {$fail_key} = { 72 | list => \@bad_comments, 73 | }; 74 | 75 | no strict 'refs'; 76 | push @tests => { 77 | name => $lang, 78 | regex => $RE {comment} {$lang}, 79 | sub => \&{"RE_comment_$lang"}, 80 | pass => [$pass_key], 81 | fail => [$fail_key], 82 | } 83 | } 84 | } 85 | 86 | run_new_tests tests => \@tests, 87 | targets => \%targets, 88 | version_from => 'Regexp::Common::comment', 89 | 90 | 91 | __END__ 92 | -------------------------------------------------------------------------------- /t/URI/tel.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common; 10 | ok; 11 | 12 | # TEST URIs 13 | 14 | try $RE{URI}{tel}; 15 | pass 'tel:+12345'; 16 | pass 'tel:+358-555-1234567'; 17 | pass 'tel:456-7890;phone-context=213'; 18 | pass 'tel:456-7890;phone-context=X-COMPANY-NET'; 19 | pass 'tel:+1-212-555-1234;tsp=terrifictelecom.com'; 20 | pass 'tel:+1-212-555-1234;tsp=terrifictelecom.com;phone-context=X-COMPANY-NET'; 21 | pass 'tel:+358-555-1234567;postd=pp22'; 22 | pass 'tel:0w003585551234567;phone-context=+3585551234'; 23 | pass 'tel:+1234567890;phone-context=+1234;vnd.company.option=foo'; 24 | pass 'tel:+1234567890;phone-context=+1234;vnd.company.option=%22foo%22'; 25 | pass 'tel:+1234;option=%22!%22'; 26 | pass 'tel:+1234;option=%22%5C%22%22'; 27 | pass 'tel:+1234;option=%22%5C!%22'; 28 | pass 'tel:+1234;option=%22bar%22'; 29 | pass 'tel:+456-7890;phone-context=213;phone-context=213'; 30 | pass 'tel:456-7890;phone-context=213;phone-context=213'; 31 | fail 'tel:456-7890'; 32 | fail 'tel:+1-800-RUN-PERL'; 33 | fail 'tel:+1234;option=%22%22%22'; 34 | fail 'tel:+1234;option=%22%5C%22'; 35 | pass 'tel:+123-456-789;isub=123(456)'; 36 | pass 'tel:+123456;postd=***'; 37 | 38 | 39 | try $RE{URI}{tel}{nofuture}; 40 | pass 'tel:+12345'; 41 | pass 'tel:+358-555-1234567'; 42 | pass 'tel:456-7890;phone-context=213'; 43 | pass 'tel:456-7890;phone-context=X-COMPANY-NET'; 44 | pass 'tel:+1-212-555-1234;tsp=terrifictelecom.com'; 45 | pass 'tel:+1-212-555-1234;tsp=terrifictelecom.com;phone-context=X-COMPANY-NET'; 46 | pass 'tel:+358-555-1234567;postd=pp22'; 47 | pass 'tel:0w003585551234567;phone-context=+3585551234'; 48 | fail 'tel:+1234567890;phone-context=+1234;vnd.company.option=foo'; 49 | fail 'tel:+1234567890;phone-context=+1234;vnd.company.option=%22foo%22'; 50 | fail 'tel:+1234;option=%22!%22'; 51 | fail 'tel:+1234;option=%22%5C%22%22'; 52 | fail 'tel:+1234;option=%22%5C!%22'; 53 | fail 'tel:+1234;option=%22bar%22'; 54 | pass 'tel:+456-7890;phone-context=213;phone-context=213'; 55 | pass 'tel:456-7890;phone-context=213;phone-context=213'; 56 | fail 'tel:456-7890'; 57 | fail 'tel:+1-800-RUN-PERL'; 58 | fail 'tel:+1234;option=%22%22%22'; 59 | fail 'tel:+1234;option=%22%5C%22'; 60 | fail 'tel:+358-555-1234567;phone-context=+1234;postd=pp22'; 61 | pass 'tel:+123-456-789;isub=123(456)'; 62 | fail 'tel:+123-456-789;isub=123(456);isub=123(456)'; 63 | fail 'tel:+123-456-789;isub=A23(456)'; 64 | pass 'tel:+123456;postd=***'; 65 | fail 'tel:1234567890;phone-context=+1234;vnd.company.option=foo'; 66 | fail 'tel:1234567890;phone-context=+1234;vnd.company.option=%22foo%22'; 67 | fail 'tel:1234;option=%22!%22'; 68 | fail 'tel:1234;option=%22%5C%22%22'; 69 | fail 'tel:1234;option=%22%5C!%22'; 70 | fail 'tel:1234;option=%22bar%22'; 71 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/telnet.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::telnet; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC1738 qw /$user $password $host $port/; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | our $VERSION = '2024080801'; 11 | 12 | 13 | my $telnet_uri = "(?k:(?k:telnet)://(?:(?k:(?k:$user)(?::(?k:$password))?)\@)?" 14 | . "(?k:(?k:$host)(?::(?k:$port))?)(?k:/)?)"; 15 | 16 | register_uri telnet => $telnet_uri; 17 | 18 | pattern name => [qw (URI telnet)], 19 | create => $telnet_uri, 20 | ; 21 | 22 | 1; 23 | 24 | __END__ 25 | 26 | =pod 27 | 28 | =head1 NAME 29 | 30 | Regexp::Common::URI::telnet -- Returns a pattern for telnet URIs. 31 | 32 | =head1 SYNOPSIS 33 | 34 | use Regexp::Common qw /URI/; 35 | 36 | while (<>) { 37 | /$RE{URI}{telnet}/ and print "Contains a telnet URI.\n"; 38 | } 39 | 40 | =head1 DESCRIPTION 41 | 42 | =head2 $RE{URI}{telnet} 43 | 44 | Returns a pattern that matches I URIs, as defined by RFC 1738. 45 | Telnet URIs have the form: 46 | 47 | "telnet:" "//" [ user [ ":" password ] "@" ] host [ ":" port ] [ "/" ] 48 | 49 | Under C<{-keep}>, the following are returned: 50 | 51 | =over 4 52 | 53 | =item $1 54 | 55 | The complete URI. 56 | 57 | =item $2 58 | 59 | The scheme. 60 | 61 | =item $3 62 | 63 | The username:password combo, or just the username if there is no password. 64 | 65 | =item $4 66 | 67 | The username, if given. 68 | 69 | =item $5 70 | 71 | The password, if given. 72 | 73 | =item $6 74 | 75 | The host:port combo, or just the host if there's no port. 76 | 77 | =item $7 78 | 79 | The host. 80 | 81 | =item $8 82 | 83 | The port, if given. 84 | 85 | =item $9 86 | 87 | The trailing slash, if any. 88 | 89 | =back 90 | 91 | =head1 REFERENCES 92 | 93 | =over 4 94 | 95 | =item B<[RFC 1738]> 96 | 97 | Berners-Lee, Tim, Masinter, L., McCahill, M.: I. December 1994. 99 | 100 | =back 101 | 102 | =head1 SEE ALSO 103 | 104 | L for other supported URIs. 105 | 106 | =head1 AUTHOR 107 | 108 | Damian Conway (damian@conway.org) 109 | 110 | =head1 MAINTENANCE 111 | 112 | This package is maintained by Abigail S<(I)>. 113 | 114 | =head1 BUGS AND IRRITATIONS 115 | 116 | Bound to be plenty. 117 | 118 | =head1 LICENSE and COPYRIGHT 119 | 120 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 121 | 122 | This module is free software, and maybe used under any of the following 123 | licenses: 124 | 125 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 126 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 127 | 3) The BSD License. See the file COPYRIGHT.BSD. 128 | 4) The MIT License. See the file COPYRIGHT.MIT. 129 | 130 | =cut 131 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes 2 | COPYRIGHT 3 | COPYRIGHT.AL 4 | COPYRIGHT.AL2 5 | COPYRIGHT.BSD 6 | COPYRIGHT.MIT 7 | lib/Regexp/Common.pm 8 | lib/Regexp/Common/_support.pm 9 | lib/Regexp/Common/balanced.pm 10 | lib/Regexp/Common/CC.pm 11 | lib/Regexp/Common/comment.pm 12 | lib/Regexp/Common/delimited.pm 13 | lib/Regexp/Common/lingua.pm 14 | lib/Regexp/Common/list.pm 15 | lib/Regexp/Common/net.pm 16 | lib/Regexp/Common/number.pm 17 | lib/Regexp/Common/profanity.pm 18 | lib/Regexp/Common/SEN.pm 19 | lib/Regexp/Common/URI.pm 20 | lib/Regexp/Common/URI/RFC1035.pm 21 | lib/Regexp/Common/URI/RFC1738.pm 22 | lib/Regexp/Common/URI/RFC1808.pm 23 | lib/Regexp/Common/URI/RFC2384.pm 24 | lib/Regexp/Common/URI/RFC2396.pm 25 | lib/Regexp/Common/URI/RFC2806.pm 26 | lib/Regexp/Common/URI/fax.pm 27 | lib/Regexp/Common/URI/file.pm 28 | lib/Regexp/Common/URI/ftp.pm 29 | lib/Regexp/Common/URI/gopher.pm 30 | lib/Regexp/Common/URI/http.pm 31 | lib/Regexp/Common/URI/news.pm 32 | lib/Regexp/Common/URI/pop.pm 33 | lib/Regexp/Common/URI/prospero.pm 34 | lib/Regexp/Common/URI/tel.pm 35 | lib/Regexp/Common/URI/telnet.pm 36 | lib/Regexp/Common/URI/tv.pm 37 | lib/Regexp/Common/URI/wais.pm 38 | lib/Regexp/Common/whitespace.pm 39 | lib/Regexp/Common/zip.pm 40 | LICENSE 41 | MANIFEST 42 | Makefile.PL 43 | README 44 | TODO 45 | t/Common.pm 46 | t/comment/delimited.t 47 | t/comment/html.t 48 | t/comment/nested.t 49 | t/comment/pascal.t 50 | t/comment/single_line.t 51 | t/comment/single_or_multiline.t 52 | t/delimited/101_delimited.t 53 | t/delimited/111_bquoted.t 54 | t/net/101_ipv4.t 55 | t/net/102_ipv4_strict.t 56 | t/net/111_ipv6.t 57 | t/net/121_mac.t 58 | t/net/131_domain.t 59 | t/number/101_integer.t 60 | t/number/111_integer_base.t 61 | t/number/121_integer_places.t 62 | t/number/122_integer_places.t 63 | t/number/123_integer_places.t 64 | t/number/131_integer_sep.t 65 | t/number/141_integer_group.t 66 | t/number/701_squares.t 67 | t/number/801_roman.t 68 | t/number/decimal.t 69 | t/number/number.t 70 | t/SEN/usa_ssn.t 71 | t/test___luhn.t 72 | t/test_balanced.t 73 | t/test_bases.t 74 | t/test_bases_sep.t 75 | t/test_comments.t 76 | t/test_curry.t 77 | t/test_i.t 78 | t/test_lingua_palindrome.t 79 | t/test_list.t 80 | t/test_no_import.t 81 | t/test_profanity.t 82 | t/test_sub.t 83 | t/test_sub_named.t 84 | t/test_ws.t 85 | t/URI/fax.t 86 | t/URI/file.t 87 | t/URI/ftp.t 88 | t/URI/gopher.t 89 | t/URI/http.t 90 | t/URI/news.t 91 | t/URI/nntp.t 92 | t/URI/pop.t 93 | t/URI/prospero.t 94 | t/URI/tel.t 95 | t/URI/telnet.t 96 | t/URI/tv.t 97 | t/URI/wais.t 98 | t/URI/any.t 99 | t/zip/101_austria.t 100 | t/zip/111_australia.t 101 | t/zip/112_australia.t 102 | t/zip/121_belgium.t 103 | t/zip/131_denmark.t 104 | t/zip/141_greenland.t 105 | t/zip/151_norway.t 106 | t/zip/161_liechtenstein.t 107 | t/zip/171_switzerland.t 108 | t/zip/181_italy.t 109 | t/zip/191_germany.t 110 | t/zip/201_luxembourg.t 111 | t/zip/211_france.t 112 | t/zip/221_monaco.t 113 | t/zip/231_san-marino.t 114 | t/zip/241_vatican-city.t 115 | t/zip/netherlands.t 116 | t/zip/spain.t 117 | t/zip/us.t 118 | t/zip/zip.t 119 | t/zip/Zip.pm 120 | -------------------------------------------------------------------------------- /t/URI/http.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common; 8 | 9 | $^W = 1; 10 | 11 | 12 | sub create_parts; 13 | 14 | my $http = $RE {URI} {HTTP}; 15 | my $https = $http -> {-scheme => 'https'}; 16 | my $any = $http -> {-scheme => 'https?'}; 17 | 18 | my @tests = ( 19 | [http => $http => {http => NORMAL_PASS | FAIL, https => NORMAL_FAIL}], 20 | [https => $https => {http => NORMAL_FAIL, https => NORMAL_PASS | FAIL}], 21 | [any => $any => {http => NORMAL_PASS, https => NORMAL_PASS}], 22 | ); 23 | 24 | my ($good, $bad) = create_parts; 25 | 26 | run_tests version => "Regexp::Common::URI", 27 | tests => \@tests, 28 | good => $good, 29 | bad => $bad, 30 | query => \&uri, 31 | wanted => \&wanted, 32 | filter => \&filter; 33 | 34 | sub uri { 35 | my ($scheme, $host, $port, $path, $query) = ($_ [0], @{$_ [1]}); 36 | 37 | my $uri = "$scheme://$host"; 38 | $uri .= ":$port" if defined $port; 39 | $uri .= "/$path" if defined $path; 40 | $uri .= "?$query" if defined $query && defined $path; 41 | 42 | $uri; 43 | } 44 | 45 | sub wanted { 46 | my ($scheme, $parts) = @_; 47 | 48 | my $abs = $parts -> [2]; 49 | $abs .= "?$parts->[3]" if defined $abs && defined $parts -> [3]; 50 | 51 | my @wanted; 52 | $wanted [0] = $_; 53 | $wanted [1] = $scheme; 54 | $wanted [2] = $parts -> [0]; 55 | $wanted [3] = $parts -> [1]; 56 | $wanted [4] = "/$abs" if defined $abs; 57 | $wanted [5] = $abs if defined $abs; 58 | $wanted [6] = $parts -> [2]; 59 | $wanted [7] = undef; 60 | $wanted [7] = $parts -> [3] if defined $parts -> [2]; 61 | 62 | \@wanted; 63 | } 64 | 65 | 66 | sub create_parts { 67 | my (@good, @bad); 68 | 69 | # Hosts. 70 | $good [0] = [qw /www.abigail.freedom.nl www.PERL.com a.b.c.d.e.f.g.h.i.j.k.x 71 | 127.0.0.1 w--w--w.abigail.freedom.nl w3.abigail.freedom.nl/]; 72 | $bad [0] = ["", qw /www.example..com w+w.example.com w--.example.com 73 | 127.0.1 127.0.0.0.1 -w.example.com www.example.1com/]; 74 | 75 | # Ports. 76 | $good [1] = [undef, "", 80]; 77 | $bad [1] = [qw /-19 : port/]; 78 | 79 | # Paths. 80 | $good [2] = [undef, "", 81 | qw {foo foo/bar/baz/bingo foo%00bar foo%EFbar 82 | %12%34%E6%7B %12%34/%E6%7B %12%34%E6%7B/foo 83 | ()() fnurd&.!~@}]; 84 | $bad [2] = [qw {foo<> foo<>bar %GGfoo foo%F %FOfoo}, '#hubba']; 85 | 86 | # Queries. 87 | $good [3] = [undef, "", qw {hubba fnurd=many&woozle=yes 88 | %3E%FF barra?femmy??dopey}]; 89 | $bad [3] = ['query#', '#query', 'qu#ry']; 90 | 91 | return (\@good, \@bad); 92 | } 93 | 94 | 95 | sub filter { 96 | return !defined $_ [0] -> [2] && defined $_ [0] -> [3] ? 0 : 1 97 | } 98 | 99 | 100 | __END__ 101 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/wais.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::wais; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC1738 qw /$host $port 6 | $search $database $wtype $wpath/; 7 | 8 | use strict; 9 | use warnings; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | 14 | my $scheme = 'wais'; 15 | my $uri = "(?k:(?k:$scheme)://(?k:$host)(?::(?k:$port))?/(?k:(?k:$database)" 16 | . "(?k:[?](?k:$search)|/(?k:$wtype)/(?k:$wpath))?))"; 17 | 18 | register_uri $scheme => $uri; 19 | 20 | pattern name => [qw (URI WAIS)], 21 | create => $uri, 22 | ; 23 | 24 | 1; 25 | 26 | __END__ 27 | 28 | =pod 29 | 30 | =head1 NAME 31 | 32 | Regexp::Common::URI::wais -- Returns a pattern for WAIS URIs. 33 | 34 | =head1 SYNOPSIS 35 | 36 | use Regexp::Common qw /URI/; 37 | 38 | while (<>) { 39 | /$RE{URI}{WAIS}/ and print "Contains a WAIS URI.\n"; 40 | } 41 | 42 | =head1 DESCRIPTION 43 | 44 | =head2 $RE{URI}{WAIS} 45 | 46 | Returns a pattern that matches I URIs, as defined by RFC 1738. 47 | WAIS URIs have the form: 48 | 49 | "wais:" "//" host [ ":" port ] "/" database 50 | [ ( "?" search ) | ( "/" wtype "/" wpath ) ] 51 | 52 | Under C<{-keep}>, the following are returned: 53 | 54 | =over 4 55 | 56 | =item $1 57 | 58 | The complete URI. 59 | 60 | =item $2 61 | 62 | The I. 63 | 64 | =item $3 65 | 66 | The I. 67 | 68 | =item $4 69 | 70 | The I, if given. 71 | 72 | =item $5 73 | 74 | The I, followed by I or I, if given. 75 | 76 | =item $6 77 | 78 | The I. 79 | 80 | =item $7 81 | 82 | The part following the I if given, including the question mark 83 | or slash. 84 | 85 | =item $8 86 | 87 | The I part, if given. 88 | 89 | =item $9 90 | 91 | The I, if given. 92 | 93 | =item $10 94 | 95 | The I, if given. 96 | 97 | =back 98 | 99 | =head1 REFERENCES 100 | 101 | =over 4 102 | 103 | =item B<[RFC 1738]> 104 | 105 | Berners-Lee, Tim, Masinter, L., McCahill, M.: I. December 1994. 107 | 108 | =back 109 | 110 | =head1 SEE ALSO 111 | 112 | L for other supported URIs. 113 | 114 | =head1 AUTHOR 115 | 116 | Damian Conway (damian@conway.org) 117 | 118 | =head1 MAINTENANCE 119 | 120 | This package is maintained by Abigail S<(I)>. 121 | 122 | =head1 BUGS AND IRRITATIONS 123 | 124 | Bound to be plenty. 125 | 126 | =head1 LICENSE and COPYRIGHT 127 | 128 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 129 | 130 | This module is free software, and maybe used under any of the following 131 | licenses: 132 | 133 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 134 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 135 | 3) The BSD License. See the file COPYRIGHT.BSD. 136 | 4) The MIT License. See the file COPYRIGHT.MIT. 137 | 138 | =cut 139 | -------------------------------------------------------------------------------- /Util/condense: -------------------------------------------------------------------------------- 1 | #!/opt/perl/bin/perl 2 | 3 | use 5.016; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | use feature 'current_sub'; 9 | use feature 'signatures'; 10 | no warnings 'experimental::signatures'; 11 | 12 | 13 | 14 | # 15 | # Given a list of digits, return a character class matching them 16 | # 17 | sub character_class (@list) { 18 | my %seen; 19 | @list = sort {$a <=> $b} grep {!$seen {$_} ++} @list; 20 | 21 | if (@list == 0) {return ""} 22 | if (@list == 1) {return $list [0]} 23 | my $out = "["; 24 | for (my $i = 0; $i < @list; $i ++) { 25 | my $j = $i + 2; 26 | if ($j < @list && $list [$j] - $list [$i] == 2) { 27 | while ($j + 1 < @list && 28 | $list [$j + 1] - $list [$i] == $j + 1 - $i) { 29 | $j ++; 30 | } 31 | $out .= $list [$i] . "-" . $list [$j]; 32 | $i = $j; 33 | } 34 | else { 35 | $out .= $list [$i]; 36 | } 37 | } 38 | $out .= "]"; 39 | return $out; 40 | } 41 | 42 | 43 | # 44 | # Given a list of numbers (all of the same length), return a regular 45 | # expression matching them 46 | # 47 | sub condense (@list) { 48 | my %seen; 49 | @list = sort {$a <=> $b} grep {!$seen {$_} ++} @list; 50 | 51 | return "" unless @list; 52 | return $list [0] if @list == 1; 53 | 54 | my $length = length ($list [0]); 55 | for (my $i = 1; $i < @list; $i ++) { 56 | die "All elements must be of the same length (@list)\n" 57 | unless length $list [$i] == $length; 58 | } 59 | 60 | # 61 | # Is there a common prefix? 62 | # 63 | my $common_prefix = $list [0]; 64 | for (my $i = 0; $i < @list && length $common_prefix; $i ++) { 65 | my $c = 0; 66 | $c ++ while $c < length $common_prefix && 67 | substr ($common_prefix, 0, $c + 1) eq 68 | substr ($list [$i], 0, $c + 1); 69 | $common_prefix = substr $common_prefix, 0, $c; 70 | } 71 | 72 | # 73 | # Chop off the common prefix 74 | # 75 | if (length $common_prefix) { 76 | my $c = length $common_prefix; 77 | foreach my $elem (@list) { 78 | substr ($elem, 0, $c) = ""; 79 | } 80 | } 81 | 82 | # 83 | # If what's left, is one character wide, return a character class 84 | # 85 | if (length ($list [0]) == 1) { 86 | return $common_prefix . character_class @list; 87 | } 88 | 89 | # 90 | # Else, bucketize on first character, recurse and combine. 91 | # 92 | my %buckets; 93 | foreach my $elem (@list) { 94 | my ($head, $tail) = $elem =~ /^(.)(.+)$/s; 95 | die "\$elem = $elem" unless defined $head; 96 | push @{$buckets {$head}} => $tail; 97 | } 98 | 99 | my @clauses; 100 | 101 | foreach my $head (sort {$a <=> $b} keys %buckets) { 102 | my $pattern = &{+__SUB__} (@{$buckets {$head}}); 103 | push @clauses => "$head$pattern"; 104 | } 105 | 106 | local $" = "|"; 107 | return "$common_prefix(?:@clauses)"; 108 | } 109 | 110 | 111 | my @list = ; 112 | chomp @list; 113 | 114 | say condense @list; 115 | 116 | 117 | __END__ 118 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/fax.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::fax; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC2806 qw /$fax_subscriber 6 | $fax_subscriber_no_future/; 7 | 8 | use strict; 9 | use warnings; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | 14 | my $fax_scheme = 'fax'; 15 | my $fax_uri = "(?k:(?k:$fax_scheme):(?k:$fax_subscriber))"; 16 | my $fax_uri_nf = "(?k:(?k:$fax_scheme):(?k:$fax_subscriber_no_future))"; 17 | 18 | register_uri $fax_scheme => $fax_uri; 19 | 20 | pattern name => [qw (URI fax)], 21 | create => $fax_uri 22 | ; 23 | 24 | pattern name => [qw (URI fax nofuture)], 25 | create => $fax_uri_nf 26 | ; 27 | 28 | 1; 29 | 30 | __END__ 31 | 32 | =pod 33 | 34 | =head1 NAME 35 | 36 | Regexp::Common::URI::fax -- Returns a pattern for fax URIs. 37 | 38 | =head1 SYNOPSIS 39 | 40 | use Regexp::Common qw /URI/; 41 | 42 | while (<>) { 43 | /$RE{URI}{fax}/ and print "Contains a fax URI.\n"; 44 | } 45 | 46 | =head1 DESCRIPTION 47 | 48 | =head2 $RE{URI}{fax} 49 | 50 | Returns a pattern that matches I URIs, as defined by RFC 2806. 51 | Under C<{-keep}>, the following are returned: 52 | 53 | =over 4 54 | 55 | =item $1 56 | 57 | The complete URI. 58 | 59 | =item $2 60 | 61 | The scheme. 62 | 63 | =item $3 64 | 65 | The phone number, including any possible add-ons like ISDN subaddress, 66 | a post dial part, area specifier, service provider, etc. 67 | 68 | =back 69 | 70 | =head2 C<$RE{URI}{fax}{nofuture}> 71 | 72 | As above (including what's returned by C<{-keep}>), with the exception 73 | that I are not allowed. Without allowing 74 | those I, it becomes much easier to check a URI if 75 | the correct syntax for post dial, service provider, phone context, 76 | etc has been used - otherwise the regex could always classify them 77 | as a I. 78 | 79 | =head1 REFERENCES 80 | 81 | =over 4 82 | 83 | =item B<[RFC 1035]> 84 | 85 | Mockapetris, P.: I. 86 | November 1987. 87 | 88 | =item B<[RFC 2396]> 89 | 90 | Berners-Lee, Tim, Fielding, R., and Masinter, L.: I. August 1998. 92 | 93 | =item B<[RFC 2806]> 94 | 95 | Vaha-Sipila, A.: I. April 2000. 96 | 97 | =back 98 | 99 | =head1 SEE ALSO 100 | 101 | L for other supported URIs. 102 | 103 | =head1 AUTHOR 104 | 105 | Damian Conway (damian@conway.org) 106 | 107 | =head1 MAINTENANCE 108 | 109 | This package is maintained by Abigail S<(I)>. 110 | 111 | =head1 BUGS AND IRRITATIONS 112 | 113 | Bound to be plenty. 114 | 115 | =head1 LICENSE and COPYRIGHT 116 | 117 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 118 | 119 | This module is free software, and maybe used under any of the following 120 | licenses: 121 | 122 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 123 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 124 | 3) The BSD License. See the file COPYRIGHT.BSD. 125 | 4) The MIT License. See the file COPYRIGHT.MIT. 126 | 127 | =cut 128 | -------------------------------------------------------------------------------- /t/net/131_domain.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common; 10 | ok; 11 | 12 | # Domains. 13 | 14 | my @data = ( 15 | ['host.example.com' => 'PPPP'], 16 | ['a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v.w.x.y.z' => 'PPPP'], 17 | ['A.B.C.D.E.F.G.H.I.J.K.L.M.N.O.P.Q.R.S.T.U.V.W.X.Y.Z' => 'PPPP'], 18 | ['host1.example.com' => 'PPPP'], 19 | ['host-1.example.com' => 'PPPP'], 20 | ['host' => 'PPPP'], 21 | ['a-----------------1.example.com' => 'PPPP'], 22 | ['a123456a.example.com' => 'PPPP'], 23 | # 24 | # 63 char limit 25 | # 26 | ['abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ-0123456789.com' 27 | => 'PPPP'], 28 | ['abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ-0123456789a.com' 29 | => 'FFFF'], 30 | # 31 | # By default, we can match a single space, but not two 32 | # 33 | [' ', => 'PFPF'], 34 | [' ' => 'FFFF'], 35 | # 36 | # Parts may only start with a number if -rfc1101 is given 37 | # 38 | ['123host.example.com' => 'FFPP'], 39 | ['host.12example.com' => 'FFPP'], 40 | # 41 | # But it may not look it starts with an IP address 42 | # 43 | ['127.0.0.1' => 'FFFF'], 44 | ['127.0.0.1.com' => 'FFFF'], 45 | ['127.0.0.1333.com' => 'FFPP'], 46 | # 47 | # Parts may not end with a dash 48 | # 49 | ['host-.example.com' => 'FFFF'], 50 | # 51 | # May not end with a dot 52 | # 53 | ['host.example.com.' => 'FFFF'], 54 | # 55 | # Mind your dots and spaces 56 | # 57 | ['host. .example.com' => 'FFFF'], 58 | ['host..example.com' => 'FFFF'], 59 | ['host .example.com' => 'FFFF'], 60 | ['ho st.example.com' => 'FFFF'], 61 | ); 62 | 63 | my @pats = ( 64 | ['$RE {net} {domain}' => $RE {net} {domain}], 65 | ['$RE {net} {domain} {-nospace}' => $RE {net} {domain} {-nospace}], 66 | ['$RE {net} {domain} {-rfc1101}' => $RE {net} {domain} {-rfc1101}], 67 | ['$RE {net} {domain} {-nospace} {-rfc1101}' 68 | => $RE {net} {domain} {-nospace} {-rfc1101}], 69 | ); 70 | 71 | 72 | foreach (my $i = 0; $i < @pats; $i ++) { 73 | my ($name, $pat) = @{$pats [$i]}; 74 | try $pat; 75 | $M .= "# Trying $name\n"; 76 | foreach my $entry (@data) { 77 | my ($domain, $results) = @$entry; 78 | my $entry = substr $results, $i, 1; 79 | $entry eq 'P' ? pass $domain : fail $domain; 80 | } 81 | } 82 | 83 | 84 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | 7 | use ExtUtils::MakeMaker; 8 | 9 | my @tests = qw [t/*.t t/*/*.t]; 10 | 11 | my %args = ( 12 | NAME => 'Regexp::Common', 13 | VERSION_FROM => 'lib/Regexp/Common.pm', 14 | ABSTRACT_FROM => 'lib/Regexp/Common.pm', 15 | PREREQ_PM => { 16 | 'vars' => 0, 17 | 'strict' => 0, 18 | 'warnings' => 0, 19 | 'Config' => 0, 20 | }, 21 | MIN_PERL_VERSION => 5.010, 22 | AUTHOR => 'Abigail ', 23 | LICENSE => 'mit', 24 | META_MERGE => { 25 | "meta-spec" => {version => 2}, 26 | license => [qw [mit bsd artistic_1 artistic_2]], 27 | 28 | # 29 | # This section is provided for laughts and giggles only. 30 | # It seems to be completely and utterly ignored when 31 | # running "perl Makefile.PL", and extracting the information 32 | # from PREREQ_PM instead. 33 | # 34 | # The result will be that less and less tests will be run, 35 | # as we're are moving towards using Test::Regexp, which is 36 | # never going to be a prerequisite to running Regexp::Common. 37 | # 38 | prereqs => { 39 | configure => { 40 | requires => { 41 | 'ExtUtils::MakeMaker' => 0, 42 | 'strict' => 0, 43 | 'warnings' => 0, 44 | }, 45 | }, 46 | runtime => { 47 | requires => { 48 | 'vars' => 0, 49 | 'strict' => 0, 50 | 'warnings' => 0, 51 | 'Config' => 0, 52 | }, 53 | }, 54 | test => { 55 | requires => { 56 | 'Test::More' => 0, 57 | }, 58 | recommends => { 59 | 'Test::Regexp' => 0, 60 | }, 61 | }, 62 | }, 63 | resources => { 64 | repository => 'git://github.com/Abigail/Regexp--Common.git', 65 | }, 66 | keywords => ['regular expression', 'pattern'], 67 | }, 68 | test => { 69 | TESTS => $^O eq 'MSWin32' 70 | ? "@{[map {glob} @tests]}" : "@tests" 71 | }, 72 | ); 73 | 74 | 75 | $args {BUILD_REQUIRES} = $args {PREREQ_PM}; 76 | $args {CONFIGURE_REQUIRES} = $args {PREREQ_PM}; 77 | $args {TEST_REQUIRES} = { 78 | %{$args {PREREQ_PM}}, 79 | "Test::More" => 0, 80 | }; 81 | 82 | 83 | my %filter = ( 84 | MIN_PERL_VERSION => '6.48', 85 | META_MERGE => '6.46', 86 | AUTHOR => '6.07', 87 | ABSTRACT_FROM => '6.07', 88 | LICENSE => '6.07', 89 | ); 90 | 91 | delete $args {$_} for grep {defined $filter {$_} && 92 | $ExtUtils::MakeMaker::VERSION lt $filter {$_}} 93 | keys %args; 94 | 95 | 96 | WriteMakefile %args; 97 | 98 | __END__ 99 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/tel.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::tel; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC2806 qw /$telephone_subscriber 6 | $telephone_subscriber_no_future/; 7 | 8 | use strict; 9 | use warnings; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | 14 | my $tel_scheme = 'tel'; 15 | my $tel_uri = "(?k:(?k:$tel_scheme):(?k:$telephone_subscriber))"; 16 | my $tel_uri_nf = "(?k:(?k:$tel_scheme):(?k:$telephone_subscriber_no_future))"; 17 | 18 | register_uri $tel_scheme => $tel_uri; 19 | 20 | pattern name => [qw (URI tel)], 21 | create => $tel_uri 22 | ; 23 | 24 | pattern name => [qw (URI tel nofuture)], 25 | create => $tel_uri_nf 26 | ; 27 | 28 | 1; 29 | 30 | __END__ 31 | 32 | =pod 33 | 34 | =head1 NAME 35 | 36 | Regexp::Common::URI::tel -- Returns a pattern for telephone URIs. 37 | 38 | =head1 SYNOPSIS 39 | 40 | use Regexp::Common qw /URI/; 41 | 42 | while (<>) { 43 | /$RE{URI}{tel}/ and print "Contains a telephone URI.\n"; 44 | } 45 | 46 | =head1 DESCRIPTION 47 | 48 | =head2 $RE{URI}{tel} 49 | 50 | Returns a pattern that matches I URIs, as defined by RFC 2806. 51 | Under C<{-keep}>, the following are returned: 52 | 53 | =over 4 54 | 55 | =item $1 56 | 57 | The complete URI. 58 | 59 | =item $2 60 | 61 | The scheme. 62 | 63 | =item $3 64 | 65 | The phone number, including any possible add-ons like ISDN subaddress, 66 | a post dial part, area specifier, service provider, etc. 67 | 68 | =back 69 | 70 | =head2 C<$RE{URI}{tel}{nofuture}> 71 | 72 | As above (including what's returned by C<{-keep}>), with the exception 73 | that I are not allowed. Without allowing 74 | those I, it becomes much easier to check a URI if 75 | the correct syntax for post dial, service provider, phone context, 76 | etc has been used - otherwise the regex could always classify them 77 | as a I. 78 | 79 | =head1 REFERENCES 80 | 81 | =over 4 82 | 83 | =item B<[RFC 1035]> 84 | 85 | Mockapetris, P.: I. 86 | November 1987. 87 | 88 | =item B<[RFC 2396]> 89 | 90 | Berners-Lee, Tim, Fielding, R., and Masinter, L.: I. August 1998. 92 | 93 | =item B<[RFC 2806]> 94 | 95 | Vaha-Sipila, A.: I. April 2000. 96 | 97 | =back 98 | 99 | =head1 SEE ALSO 100 | 101 | L for other supported URIs. 102 | 103 | =head1 AUTHOR 104 | 105 | Damian Conway (damian@conway.org) 106 | 107 | =head1 MAINTENANCE 108 | 109 | This package is maintained by Abigail S<(I)>. 110 | 111 | =head1 BUGS AND IRRITATIONS 112 | 113 | Bound to be plenty. 114 | 115 | =head1 LICENSE and COPYRIGHT 116 | 117 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 118 | 119 | This module is free software, and maybe used under any of the following 120 | licenses: 121 | 122 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 123 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 124 | 3) The BSD License. See the file COPYRIGHT.BSD. 125 | 4) The MIT License. See the file COPYRIGHT.MIT. 126 | 127 | =cut 128 | -------------------------------------------------------------------------------- /t/URI/prospero.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common; 8 | 9 | $^W = 1; 10 | $DEBUG = 1; 11 | 12 | 13 | sub create_parts; 14 | 15 | my $prospero = $RE {URI} {prospero}; 16 | 17 | # No point in crosschecking, URI creation is tag independent. 18 | my @tests = ( 19 | [prospero => $prospero => {prospero => NORMAL_PASS | FAIL}], 20 | ); 21 | 22 | my ($good, $bad) = create_parts; 23 | 24 | run_tests version => "Regexp::Common::URI::prospero", 25 | tests => \@tests, 26 | good => $good, 27 | bad => $bad, 28 | query => \&prospero, 29 | wanted => \&wanted, 30 | filter => \&filter, 31 | ; 32 | 33 | sub prospero { 34 | my ($tag, $host, $port, $ppath, $fieldnames, $fieldvalues) = 35 | ($_ [0], @{$_ [1]}); 36 | 37 | my $prospero = "prospero://"; 38 | $prospero .= $host if defined $host; 39 | $prospero .= ":$port" if defined $port; 40 | $prospero .= "/$ppath" if defined $ppath; 41 | if (defined $fieldnames) { 42 | foreach my $i (0 .. $#$fieldnames) { 43 | $prospero .= ";$fieldnames->[$i]"; 44 | $prospero .= "=$fieldvalues->[$i]" if defined $fieldvalues -> [$i]; 45 | } 46 | } 47 | 48 | $prospero; 49 | } 50 | 51 | sub wanted { 52 | my ($tag, $parts) = @_; 53 | 54 | my @wanted; 55 | $wanted [0] = $_; 56 | $wanted [1] = "prospero"; 57 | $wanted [2] = $$parts [0]; # host. 58 | $wanted [3] = $$parts [1]; # port. 59 | $wanted [4] = $$parts [2]; # ppart. 60 | $wanted [5] = ""; 61 | if (defined $$parts [3]) { 62 | foreach my $i (0 .. $#{$$parts [3]}) { 63 | $wanted [5] .= ";${$$parts [3]}[$i]=${$$parts [4]}[$i]"; 64 | } 65 | } 66 | 67 | \@wanted; 68 | } 69 | 70 | 71 | sub create_parts { 72 | my (@good, @bad); 73 | 74 | # Hosts. 75 | $good [0] = [qw /www.abigail.freedom.nl www.PERL.com a.b.c.d.e.f.g.h.i.j.k.x 76 | 127.0.0.1 w--w--w.abigail.freedom.nl w3.abigail.freedom.nl/]; 77 | $bad [0] = [qw /www.example..com w+w.example.com w--.example.com 78 | 127.0.0.0.1 -w.example.com www.example.1com/]; 79 | 80 | # Ports. 81 | $good [1] = [undef, 1525]; 82 | $bad [1] = ["", qw /: port/]; 83 | 84 | # Ppart 85 | $good [2] = ["", qw {part foo/bar fnord:&=?%FF}]; 86 | $bad [2] = [undef, qw {~}, ' ']; 87 | 88 | # Fieldname 89 | $good [3] = [undef, [qw /name/], [qw /name1 name2/], [""], ["", ""], 90 | ["", qw /name/], [qw /fnord:&?%FF/]]; 91 | $bad [3] = [[qw /name==/], ['~']]; 92 | 93 | # Fieldvalue 94 | $good [4] = [undef, [qw /value/], [qw /value1 value2/], [""], ["", ""], 95 | ["", qw /value/], [qw /fnord:&?%FF/]]; 96 | $bad [4] = [[qw /value==/], ['~'], [undef], [undef, undef]]; 97 | 98 | return (\@good, \@bad); 99 | } 100 | 101 | 102 | sub filter { 103 | return 1 if !defined ${$_ [0]} [3] && !defined ${$_ [0]} [4]; 104 | return 0 if defined ${$_ [0]} [3] && !defined ${$_ [0]} [4] || 105 | !defined ${$_ [0]} [3] && defined ${$_ [0]} [4]; 106 | return 0 if @{${$_ [0]} [3]} != @{${$_ [0]} [4]}; 107 | 108 | return 1; 109 | } 110 | 111 | 112 | __END__ 113 | -------------------------------------------------------------------------------- /t/comment/delimited.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib "blib/lib", "."; 5 | 6 | use Regexp::Common qw /RE_comment_ALL/; 7 | use t::Common qw /run_new_tests/; 8 | 9 | use warnings; 10 | 11 | 12 | my @delimited = do { 13 | no warnings; 14 | ( [qw {comment ;} => ['Algol 60']], 15 | [qw {/* */} => [qw {ALPACA B C C-- LPC PL/I}]], 16 | [qw {; ;} => [qw {Befunge-98 Funge-98 Shelta}]], 17 | [qw {} => [qw {BML}]], 18 | [qw !{ }! => [qw {False}]], 19 | [qw {, ,} => [qw {Haifu}]], 20 | [qw {/** */} => [qw {JavaDoc}]], 21 | [qw {(* *)} => [qw {Oberon}]], 22 | [qw {" "} => [qw {Smalltalk}]], 23 | [qw {|| !!} => [qw {*W}]], 24 | ) 25 | }; 26 | 27 | 28 | # 29 | # Some basic comments, not including delimiters. 30 | # 31 | my @comments = ("", "This is a comment", "This is a\nmultiline comment", 32 | "\n", "*", "\n*\n", "/*", "(*", "||", "{"); 33 | 34 | # Targets, and test suites. 35 | my %targets; 36 | my @tests; 37 | 38 | foreach my $entry (@delimited) { 39 | my ($start, $end) = @$entry [0, 1]; 40 | my $langs = $$entry [2]; 41 | my $pass_key = "pass_${start}_${end}"; 42 | my $fail_key = "fail_${start}_${end}"; 43 | 44 | $targets {$pass_key} = { 45 | list => \@comments, 46 | query => sub {$start . $_ [0] . $end}, 47 | wanted => sub {$_, $start, $_ [0], $end}, 48 | }; 49 | 50 | # Create bad comments. 51 | my @bad_comments; 52 | # No terminating token. 53 | push @bad_comments => map {"$start$_"} @comments; 54 | # No starting token. 55 | push @bad_comments => map {"$_$end"} grep {index ($_, $start)} @comments; 56 | # Double terminators. 57 | push @bad_comments => map {"$start$_$end$end"} @comments; 58 | # Double the comment. 59 | push @bad_comments => map {"$start$_$end" x 2} @comments; 60 | # Different token. 61 | my @bad_tokens = grep {index $_ -> [0], $start} @delimited; 62 | push @bad_comments => map {my $c = $_; 63 | map {$_ -> [0] . $c . $_ -> [1]} @bad_tokens 64 | } @comments; 65 | # No tokens. 66 | push @bad_comments => @comments; 67 | # Text preceeding comment. 68 | push @bad_comments => map {"Text $start$_$end"} @comments; 69 | # Some more. 70 | push @bad_comments => ""; 71 | push @bad_comments => "/* This is a C comment */" if $start ne '/*'; 72 | push @bad_comments => "{ This is a Pascal comment }" if $start ne '{'; 73 | 74 | $targets {$fail_key} = { 75 | list => \@bad_comments, 76 | }; 77 | 78 | foreach my $lang (@$langs) { 79 | my $langX = $lang; 80 | $langX =~ s/\W/X/g; 81 | no strict 'refs'; 82 | push @tests => { 83 | name => $lang, 84 | regex => $RE {comment} {$lang}, 85 | sub => \&{"RE_comment_$langX"}, 86 | pass => [$pass_key], 87 | fail => [$fail_key], 88 | skip_sub => sub {$lang eq 'JavaDoc' && $_ [0] eq 'fail' && 89 | $_ [1] eq '/***/'}, 90 | } 91 | } 92 | } 93 | 94 | run_new_tests tests => \@tests, 95 | targets => \%targets, 96 | version_from => 'Regexp::Common::comment', 97 | 98 | 99 | __END__ 100 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/http.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::http; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC2396 qw /$host $port $path_segments $query/; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | our $VERSION = '2024080801'; 11 | 12 | 13 | my $http_uri = "(?k:(?k:http)://(?k:$host)(?::(?k:$port))?" . 14 | "(?k:/(?k:(?k:$path_segments)(?:[?](?k:$query))?))?)"; 15 | 16 | my $https_uri = $http_uri; $https_uri =~ s/http/https?/; 17 | 18 | register_uri HTTP => $https_uri; 19 | 20 | pattern name => [qw (URI HTTP), "-scheme=http"], 21 | create => sub { 22 | my $scheme = $_ [1] -> {-scheme}; 23 | my $uri = $http_uri; 24 | $uri =~ s/http/$scheme/; 25 | $uri; 26 | } 27 | ; 28 | 29 | 1; 30 | 31 | __END__ 32 | 33 | =pod 34 | 35 | =head1 NAME 36 | 37 | Regexp::Common::URI::http -- Returns a pattern for HTTP URIs. 38 | 39 | =head1 SYNOPSIS 40 | 41 | use Regexp::Common qw /URI/; 42 | 43 | while (<>) { 44 | /$RE{URI}{HTTP}/ and print "Contains an HTTP URI.\n"; 45 | } 46 | 47 | =head1 DESCRIPTION 48 | 49 | =head2 $RE{URI}{HTTP}{-scheme} 50 | 51 | Provides a regex for an HTTP URI as defined by RFC 2396 (generic syntax) 52 | and RFC 2616 (HTTP). 53 | 54 | If C<< -scheme => I

>> is specified the pattern I

is used as the scheme. 55 | By default I

is C. C and C are reasonable 56 | alternatives. 57 | 58 | The syntax for an HTTP URI is: 59 | 60 | "http:" "//" host [ ":" port ] [ "/" path [ "?" query ]] 61 | 62 | Under C<{-keep}>, the following are returned: 63 | 64 | =over 4 65 | 66 | =item $1 67 | 68 | The entire URI. 69 | 70 | =item $2 71 | 72 | The scheme. 73 | 74 | =item $3 75 | 76 | The host (name or address). 77 | 78 | =item $4 79 | 80 | The port (if any). 81 | 82 | =item $5 83 | 84 | The absolute path, including the query and leading slash. 85 | 86 | =item $6 87 | 88 | The absolute path, including the query, without the leading slash. 89 | 90 | =item $7 91 | 92 | The absolute path, without the query or leading slash. 93 | 94 | =item $8 95 | 96 | The query, without the question mark. 97 | 98 | =back 99 | 100 | =head1 REFERENCES 101 | 102 | =over 4 103 | 104 | =item B<[RFC 2396]> 105 | 106 | Berners-Lee, Tim, Fielding, R., and Masinter, L.: I. August 1998. 108 | 109 | =item B<[RFC 2616]> 110 | 111 | Fielding, R., Gettys, J., Mogul, J., Frystyk, H., Masinter, L., 112 | Leach, P. and Berners-Lee, Tim: I. 113 | June 1999. 114 | 115 | =back 116 | 117 | =head1 SEE ALSO 118 | 119 | L for other supported URIs. 120 | 121 | =head1 AUTHOR 122 | 123 | Damian Conway (damian@conway.org) 124 | 125 | =head1 MAINTENANCE 126 | 127 | This package is maintained by Abigail S<(I)>. 128 | 129 | =head1 BUGS AND IRRITATIONS 130 | 131 | Bound to be plenty. 132 | 133 | =head1 LICENSE and COPYRIGHT 134 | 135 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 136 | 137 | This module is free software, and maybe used under any of the following 138 | licenses: 139 | 140 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 141 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 142 | 3) The BSD License. See the file COPYRIGHT.BSD. 143 | 4) The MIT License. See the file COPYRIGHT.MIT. 144 | 145 | =cut 146 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/news.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::news; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC1738 qw /$grouppart $group $article 6 | $host $port $digits/; 7 | 8 | use strict; 9 | use warnings; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | 14 | my $news_scheme = 'news'; 15 | my $news_uri = "(?k:(?k:$news_scheme):(?k:$grouppart))"; 16 | 17 | my $nntp_scheme = 'nntp'; 18 | my $nntp_uri = "(?k:(?k:$nntp_scheme)://(?k:(?k:(?k:$host)(?::(?k:$port))?)" 19 | . "/(?k:$group)(?:/(?k:$digits))?))"; 20 | 21 | register_uri $news_scheme => $news_uri; 22 | register_uri $nntp_scheme => $nntp_uri; 23 | 24 | pattern name => [qw (URI news)], 25 | create => $news_uri, 26 | ; 27 | 28 | pattern name => [qw (URI NNTP)], 29 | create => $nntp_uri, 30 | ; 31 | 32 | 1; 33 | 34 | __END__ 35 | 36 | =pod 37 | 38 | =head1 NAME 39 | 40 | Regexp::Common::URI::news -- Returns a pattern for file URIs. 41 | 42 | =head1 SYNOPSIS 43 | 44 | use Regexp::Common qw /URI/; 45 | 46 | while (<>) { 47 | /$RE{URI}{news}/ and print "Contains a news URI.\n"; 48 | } 49 | 50 | =head1 DESCRIPTION 51 | 52 | =head2 $RE{URI}{news} 53 | 54 | Returns a pattern that matches I URIs, as defined by RFC 1738. 55 | News URIs have the form: 56 | 57 | "news:" ( "*" | group | article "@" host ) 58 | 59 | Under C<{-keep}>, the following are returned: 60 | 61 | =over 4 62 | 63 | =item $1 64 | 65 | The complete URI. 66 | 67 | =item $2 68 | 69 | The scheme. 70 | 71 | =item $3 72 | 73 | The part of the URI following "news://". 74 | 75 | =back 76 | 77 | =head2 $RE{URI}{NNTP} 78 | 79 | Returns a pattern that matches I URIs, as defined by RFC 1738. 80 | NNTP URIs have the form: 81 | 82 | "nntp://" host [ ":" port ] "/" group [ "/" digits ] 83 | 84 | Under C<{-keep}>, the following are returned: 85 | 86 | =over 4 87 | 88 | =item $1 89 | 90 | The complete URI. 91 | 92 | =item $2 93 | 94 | The scheme. 95 | 96 | =item $3 97 | 98 | The part of the URI following "nntp://". 99 | 100 | =item $4 101 | 102 | The host and port, separated by a colon. If no port was given, just 103 | the host. 104 | 105 | =item $5 106 | 107 | The host. 108 | 109 | =item $6 110 | 111 | The port, if given. 112 | 113 | =item $7 114 | 115 | The group. 116 | 117 | =item $8 118 | 119 | The digits, if given. 120 | 121 | =back 122 | 123 | =head1 REFERENCES 124 | 125 | =over 4 126 | 127 | =item B<[RFC 1738]> 128 | 129 | Berners-Lee, Tim, Masinter, L., McCahill, M.: I. December 1994. 131 | 132 | =back 133 | 134 | =head1 SEE ALSO 135 | 136 | L for other supported URIs. 137 | 138 | =head1 AUTHOR 139 | 140 | Damian Conway (damian@conway.org) 141 | 142 | =head1 MAINTENANCE 143 | 144 | This package is maintained by Abigail S<(I)>. 145 | 146 | =head1 BUGS AND IRRITATIONS 147 | 148 | Bound to be plenty. 149 | 150 | =head1 LICENSE and COPYRIGHT 151 | 152 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 153 | 154 | This module is free software, and maybe used under any of the following 155 | licenses: 156 | 157 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 158 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 159 | 3) The BSD License. See the file COPYRIGHT.BSD. 160 | 4) The MIT License. See the file COPYRIGHT.MIT. 161 | 162 | =cut 163 | -------------------------------------------------------------------------------- /t/net/121_mac.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common; 10 | ok; 11 | 12 | try $RE{net}{MAC}; 13 | 14 | pass '0:0:0:0:0:0'; 15 | pass '1:1:1:1:1:1'; 16 | pass 'a:b:c:d:e:f'; 17 | pass 'a0:b0:c0:d0:e0:f0'; 18 | pass 'a0:b0:6:80:e0:f'; 19 | fail '0:0:0:0:0'; 20 | fail '1:1:1:1:1:1:1'; 21 | fail 'a:b:c:d:e:g'; 22 | fail 'a0-b0-c0-d0-e0-f0'; 23 | fail '255:255:255:255:255:255'; 24 | 25 | try $RE{net}{MAC}{hex}; 26 | 27 | pass '0:0:0:0:0:0'; 28 | pass '1:1:1:1:1:1'; 29 | pass 'a:b:c:d:e:f'; 30 | pass 'a0:b0:c0:d0:e0:f0'; 31 | pass 'a0:b0:6:80:e0:f'; 32 | fail '0:0:0:0:0'; 33 | fail '1:1:1:1:1:1:1'; 34 | fail 'a:b:c:d:e:g'; 35 | fail 'a0-b0-c0-d0-e0-f0'; 36 | fail '255:255:255:255:255:255'; 37 | 38 | try $RE{net}{MAC}{dec}; 39 | 40 | pass '0:0:0:0:0:0'; 41 | pass '1:1:1:1:1:1'; 42 | pass '10:11:12:13:14:15'; 43 | pass '255:255:255:56:255:255'; 44 | pass '255:255:27:255:255:255'; 45 | pass '255:255:255:255:255:30'; 46 | fail '0:0:0:0:0'; 47 | fail '1:1:1:1:1:1:1'; 48 | fail 'a:b:c:d:e:f'; 49 | fail '0-0-0-0-0--0'; 50 | fail '255:255:255:256:255:255:'; 51 | fail '255:255:274:255:255:255:'; 52 | fail '255:255:255:255:255:300:'; 53 | 54 | try $RE{net}{MAC}{oct}; 55 | 56 | pass '0:0:0:0:0:0'; 57 | pass '1:1:1:1:1:1'; 58 | pass '10:11:12:13:14:15'; 59 | pass '377:377:377:56:377:377'; 60 | pass '377:377:27:377:377:377'; 61 | pass '377:377:377:377:377:30'; 62 | fail '0:0:0:0:0'; 63 | fail '1:1:1:1:1:1:1'; 64 | fail '1:1:1:1:8:1'; 65 | fail 'a:b:c:d:e:f'; 66 | fail '0-0-0-0-0-0'; 67 | fail '377:377:377:400:377:377'; 68 | fail '377:377:379:377:377:377'; 69 | fail '377:377:377:377:377:380'; 70 | 71 | try $RE{net}{MAC}{bin}; 72 | 73 | pass '0:0:0:0:0:0'; 74 | pass '1:1:1:1:1:1'; 75 | pass '10:11:100:101:110:111'; 76 | pass '11111111:11111111:11111111:1111111:11111111:11111111'; 77 | pass '11111111:11111111:11111111:11111110:11111111:11111111'; 78 | pass '11111111:11111111:11111111:11111111:11111111:11111111'; 79 | fail '0:0:0:0:0'; 80 | fail '1:1:1:1:1:1:1'; 81 | fail '1:1:1:1:111111111:1'; 82 | fail 'a:b:c:d:e:f'; 83 | fail '0-0-0-0-0-0'; 84 | 85 | try $RE{net}{MAC}{hex}{-sep => ""}; 86 | 87 | pass '000000'; 88 | pass '111111'; 89 | pass 'abcdef'; 90 | pass 'a0b0c0d0e0f'; 91 | pass 'a0b0680e0f'; 92 | fail 'cdefgh'; 93 | fail 'a0-b0-c0-d0-e0-f0'; 94 | fail '255255255255255255'; 95 | 96 | try $RE{net}{MAC}{hex}{-sep => " "}; 97 | 98 | pass '0 0 0 0 0 0'; 99 | pass '1 1 1 1 1 1'; 100 | pass 'a b c d e f'; 101 | pass 'a0 b0 c0 d0 e0 f0'; 102 | pass 'a0 b0 6 80 e0 f'; 103 | fail '0 0 0 0 0'; 104 | fail '1 1 1 1 1 1 1'; 105 | fail 'c d e f g h'; 106 | fail 'a0-b0-c0-d0-e0-f0'; 107 | fail '255 255 255 255 255 255'; 108 | 109 | 110 | ok '08:09:0a:0b:0c:0d' eq 111 | $RE{net}{MAC} -> subs ('8:9:a:b:c:d'); 112 | ok '08:09:0a:0b:0c:0d' eq 113 | $RE{net}{MAC}{hex} -> subs ('8:9:a:b:c:d'); 114 | ok '08:09:0a:0b:0c:0d' eq 115 | $RE{net}{MAC}{hex}{-sep => '-'} -> subs ('8-9-a-b-c-d'); 116 | ok '08:09:0a:0b:0c:0d' eq 117 | $RE{net}{MAC}{hex}{-sep => ''} -> subs ('89abcd'); 118 | ok '08:09:0a:0b:0c:0d' eq 119 | $RE{net}{MAC}{dec} -> subs ('8:9:10:11:12:13'); 120 | ok '08:09:0a:0b:0c:0d' eq 121 | $RE{net}{MAC}{oct} -> subs ('10:11:12:13:14:15'); 122 | ok '08:09:0a:0b:0c:0d' eq 123 | $RE{net}{MAC}{bin} -> subs ('1000:1001:1010:1011:1100:1101'); 124 | ok '8:9:a:b:c:g' eq 125 | $RE{net}{MAC}{hex} -> subs ('8:9:a:b:c:g'); 126 | -------------------------------------------------------------------------------- /lib/Regexp/Common/CC.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::CC; 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Regexp::Common qw /pattern clean no_defaults/; 10 | use Regexp::Common::_support qw /luhn/; 11 | 12 | our $VERSION = '2024080801'; 13 | 14 | my @cards = ( 15 | # Name Prefix Length mod 10 16 | [Mastercard => '5[1-5]', 16, 1], 17 | [Visa => '4', [13, 16], 1], 18 | [Amex => '3[47]', 15, 1], 19 | # Carte Blanche 20 | ['Diners Club' => '3(?:0[0-5]|[68])', 14, 1], 21 | [Discover => '6011', 16, 1], 22 | [enRoute => '2(?:014|149)', 15, 0], 23 | [JCB => [['3', 16, 1], 24 | ['2131|1800', 15, 1]]], 25 | ); 26 | 27 | 28 | foreach my $card (@cards) { 29 | my ($name, $prefix, $length, $mod) = @$card; 30 | 31 | # Skip the harder ones for now. 32 | next if ref $prefix || ref $length; 33 | next unless $mod; 34 | 35 | my $times = $length + $mod; 36 | pattern name => [CC => $name], 37 | create => sub { 38 | use re 'eval'; 39 | qr <((?=($prefix))[0-9]{$length}) 40 | (?(?{Regexp::Common::_support::luhn $1})|(?!))>x 41 | } 42 | ; 43 | } 44 | 45 | 46 | 47 | 48 | 1; 49 | 50 | __END__ 51 | 52 | =pod 53 | 54 | =head1 NAME 55 | 56 | Regexp::Common::CC -- provide patterns for credit card numbers. 57 | 58 | =head1 SYNOPSIS 59 | 60 | use Regexp::Common qw /CC/; 61 | 62 | while (<>) { 63 | /^$RE{CC}{Mastercard}$/ and print "Mastercard card number\n"; 64 | } 65 | 66 | =head1 DESCRIPTION 67 | 68 | Please consult the manual of L for a general description 69 | of the works of this interface. 70 | 71 | Do not use this module directly, but load it via I. 72 | 73 | This module offers patterns for credit card numbers of several major 74 | credit card types. Currently, the supported cards are: I, 75 | I, I, and I. 76 | 77 | 78 | =head1 SEE ALSO 79 | 80 | L for a general description of how to use this interface. 81 | 82 | =over 4 83 | 84 | =item L 85 | 86 | Credit Card Validation - Check Digits 87 | 88 | =item L 89 | 90 | Everything you ever wanted to know about CC's 91 | 92 | =item L 93 | 94 | Luhn formula 95 | 96 | =back 97 | 98 | =head1 AUTHORS 99 | 100 | Damian Conway S<(I)> and 101 | Abigail S<(I)>. 102 | 103 | =head1 MAINTENANCE 104 | 105 | This package is maintained by Abigail S<(I)>. 106 | 107 | =head1 BUGS AND IRRITATIONS 108 | 109 | Bound to be plenty. Send them in to S>. 110 | 111 | =head1 LICENSE and COPYRIGHT 112 | 113 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 114 | 115 | This module is free software, and maybe used under any of the following 116 | licenses: 117 | 118 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 119 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 120 | 3) The BSD License. See the file COPYRIGHT.BSD. 121 | 4) The MIT License. See the file COPYRIGHT.MIT. 122 | 123 | =cut 124 | -------------------------------------------------------------------------------- /t/URI/fax.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common; 10 | ok; 11 | 12 | # TEST URIs 13 | 14 | try $RE{URI}{fax}; 15 | pass 'fax:+12345'; 16 | pass 'fax:+358-555-1234567'; 17 | pass 'fax:456-7890;phone-context=213'; 18 | pass 'fax:456-7890;phone-context=X-COMPANY-NET'; 19 | pass 'fax:+1-212-555-1234;tsp=terrifictelecom.com'; 20 | pass 'fax:+1-212-555-1234;tsp=terrifictelecom.com;phone-context=X-COMPANY-NET'; 21 | pass 'fax:+358-555-1234567;postd=pp22'; 22 | pass 'fax:0w003585551234567;phone-context=+3585551234'; 23 | pass 'fax:+1234567890;phone-context=+1234;vnd.company.option=foo'; 24 | pass 'fax:+1234567890;phone-context=+1234;vnd.company.option=%22foo%22'; 25 | pass 'fax:+1234;option=%22!%22'; 26 | pass 'fax:+1234;option=%22%5C%22%22'; 27 | pass 'fax:+1234;option=%22%5C!%22'; 28 | pass 'fax:+1234;option=%22bar%22'; 29 | pass 'fax:+456-7890;phone-context=213;phone-context=213'; 30 | pass 'fax:456-7890;phone-context=213;phone-context=213'; 31 | pass 'fax:+12345;tsub=0123456789-.()'; 32 | pass 'fax:+358-555-123456;tsub=0123456789-.()7'; 33 | pass 'fax:456-7890;tsub=0123456789-.();phone-context=213'; 34 | pass 'fax:456-7890;tsub=0123456789-.();phone-context=X-COMPANY-NET'; 35 | pass 'fax:+1-212-555-1234;tsub=0123456789-.();tsp=terrifictelecom.com;phone-context=X-COMPANY-NET'; 36 | fail 'fax:456-7890'; 37 | fail 'fax:+1-800-RUN-PERL'; 38 | fail 'fax:+1234;option=%22%22%22'; 39 | fail 'fax:+1234;option=%22%5C%22'; 40 | pass 'fax:+123-456-789;isub=123(456)'; 41 | pass 'fax:+123456;postd=***'; 42 | fail 'fax:456-7890;phone-context=213;tsub=0123456789-.()'; 43 | fail 'fax:456-7890;tsub=213;tsub=456'; 44 | fail 'fax:456-7890;tsub=213;'; 45 | 46 | 47 | try $RE{URI}{fax}{nofuture}; 48 | pass 'fax:+12345'; 49 | pass 'fax:+358-555-1234567'; 50 | pass 'fax:456-7890;phone-context=213'; 51 | pass 'fax:456-7890;phone-context=X-COMPANY-NET'; 52 | pass 'fax:+1-212-555-1234;tsp=terrifictelecom.com'; 53 | pass 'fax:+1-212-555-1234;tsp=terrifictelecom.com;phone-context=X-COMPANY-NET'; 54 | pass 'fax:+358-555-1234567;postd=pp22'; 55 | pass 'fax:0w003585551234567;phone-context=+3585551234'; 56 | fail 'fax:+1234567890;phone-context=+1234;vnd.company.option=foo'; 57 | fail 'fax:+1234567890;phone-context=+1234;vnd.company.option=%22foo%22'; 58 | fail 'fax:+1234;option=%22!%22'; 59 | fail 'fax:+1234;option=%22%5C%22%22'; 60 | fail 'fax:+1234;option=%22%5C!%22'; 61 | fail 'fax:+1234;option=%22bar%22'; 62 | pass 'fax:+456-7890;phone-context=213;phone-context=213'; 63 | pass 'fax:456-7890;phone-context=213;phone-context=213'; 64 | fail 'fax:456-7890'; 65 | fail 'fax:+1-800-RUN-PERL'; 66 | fail 'fax:+1234;option=%22%22%22'; 67 | fail 'fax:+1234;option=%22%5C%22'; 68 | fail 'fax:+358-555-1234567;phone-context=+1234;postd=pp22'; 69 | pass 'fax:+123-456-789;isub=123(456)'; 70 | fail 'fax:+123-456-789;isub=123(456);isub=123(456)'; 71 | fail 'fax:+123-456-789;isub=A23(456)'; 72 | pass 'fax:+123456;postd=***'; 73 | fail 'fax:1234567890;phone-context=+1234;vnd.company.option=foo'; 74 | fail 'fax:1234567890;phone-context=+1234;vnd.company.option=%22foo%22'; 75 | fail 'fax:1234;option=%22!%22'; 76 | fail 'fax:1234;option=%22%5C%22%22'; 77 | fail 'fax:1234;option=%22%5C!%22'; 78 | fail 'fax:1234;option=%22bar%22'; 79 | fail 'fax:+12345;tsub=foo'; 80 | fail 'fax:456-7890;tsub=213;tsub=456'; 81 | fail 'fax:456-7890;tsub=213;'; 82 | pass 'fax:456-7890;tsub=0123456789-.();phone-context=213'; 83 | pass 'fax:456-7890;tsub=0123456789-.();phone-context=X-COMPANY-NET'; 84 | pass 'fax:+1-212-555-1234;tsub=0123456789-.();tsp=terrifictelecom.com;phone-context=X-COMPANY-NET'; 85 | -------------------------------------------------------------------------------- /t/number/123_integer_places.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use Regexp::Common; 8 | use Test::More; 9 | 10 | my $r = eval "require Test::Regexp; 1"; 11 | 12 | unless ($r) { 13 | print "1..0 # SKIP Test::Regexp not found\n"; 14 | exit; 15 | } 16 | 17 | sub make_test { 18 | my ($name, $base, @options) = @_; 19 | my $pat = $base; 20 | while (@options) { 21 | my $opt = shift @options; 22 | if (@options && $options [0] !~ /^-/) { 23 | my $val = shift @options; 24 | $pat = $$pat {$opt => $val}; 25 | $name .= ", $opt => $val"; 26 | } 27 | else { 28 | $pat = $$pat {$opt}; 29 | $name .= ", $opt"; 30 | } 31 | } 32 | my $keep = $$pat {-keep}; 33 | Test::Regexp:: -> new -> init ( 34 | pattern => $pat, 35 | keep_pattern => $keep, 36 | name => $name, 37 | ); 38 | } 39 | 40 | 41 | # 42 | # Combine places and bases 43 | # 44 | my $min = 3; 45 | my $max = 6; 46 | my $pattern = make_test "Integer pattern" => 47 | $RE {num} {int}, -base => 4, 48 | -places => "$min,$max"; 49 | my $pattern_neg = make_test "Integer pattern" => 50 | $RE {num} {int}, -base => 4, 51 | -places => "$min,$max", 52 | -sign => '[-]'; 53 | 54 | 55 | my @numbers; 56 | 57 | push @numbers => map {"0" x $_} 1 .. 7; 58 | push @numbers => qw [ 59 | 1201201 21013 120 123100 3210310 1231231013 2130130 2130 31230 60 | 13012302 13130 61 | ]; 62 | 63 | 64 | foreach my $number (@numbers) { 65 | my $length = length $number; 66 | if ($length < $min) { 67 | foreach my $subj ($number, "-$number", "+$number") { 68 | $pattern -> no_match ($number, reason => "Number too short"); 69 | $pattern_neg -> no_match ($number, reason => "Number too short"); 70 | } 71 | } 72 | elsif ($length > $max) { 73 | foreach my $subj ($number, "-$number", "+$number") { 74 | $pattern -> no_match ($number, reason => "Number too long"); 75 | $pattern_neg -> no_match ($number, reason => "Number too long"); 76 | } 77 | } 78 | else { 79 | $pattern -> match ($number, [$number, "", $number], 80 | test => "Number of correct length"); 81 | $pattern_neg -> no_match ($number, reason => "Number not signed"); 82 | $pattern -> match ("-$number", ["-$number", "-", $number], 83 | test => "Signed number of correct length"); 84 | $pattern_neg -> match ("-$number", ["-$number", "-", $number], 85 | test => "Signed number of correct length"); 86 | $pattern -> match ("+$number", ["+$number", "+", $number], 87 | test => "Signed number of correct length"); 88 | $pattern_neg -> no_match ($number, 89 | reason => "Number incorrectly signed"); 90 | } 91 | } 92 | 93 | my @bad_characters = ( 94 | ["Number contains space", "12 12", "111 1"], 95 | ["Digit exceeds base", "1234", "4", "121212124", "9123123123"], 96 | ["Letter in number", "123A", "Q", "202O20", "123Z21"], 97 | ); 98 | 99 | foreach my $entry (@bad_characters) { 100 | my ($reason, @subjs) = @$entry; 101 | foreach my $subj (@subjs) { 102 | $pattern -> no_match ($subj, reason => $reason); 103 | $pattern_neg -> no_match ($subj, reason => $reason); 104 | } 105 | } 106 | 107 | done_testing (); 108 | 109 | 110 | __END__ 111 | -------------------------------------------------------------------------------- /t/number/121_integer_places.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use Regexp::Common; 8 | use Test::More; 9 | 10 | my $r = eval "require Test::Regexp; 1"; 11 | 12 | unless ($r) { 13 | print "1..0 # SKIP Test::Regexp not found\n"; 14 | exit; 15 | } 16 | 17 | 18 | sub make_test { 19 | my ($name, $base, @options) = @_; 20 | my $pat = $base; 21 | while (@options) { 22 | my $opt = shift @options; 23 | if (@options && $options [0] !~ /^-/) { 24 | my $val = shift @options; 25 | $pat = $$pat {$opt => $val}; 26 | $name .= ", $opt => $val"; 27 | } 28 | else { 29 | $pat = $$pat {$opt}; 30 | $name .= ", $opt"; 31 | } 32 | } 33 | my $keep = $$pat {-keep}; 34 | Test::Regexp:: -> new -> init ( 35 | pattern => $pat, 36 | keep_pattern => $keep, 37 | name => $name, 38 | ); 39 | } 40 | 41 | # 42 | # Patterns with fixed places. 43 | # 44 | my @places = (1, 2, 3, 5, 8, 13, 21, 34); 45 | 46 | my %patterns; 47 | 48 | foreach my $places (@places) { 49 | my $places_pattern = make_test "Integer pattern", 50 | $RE {num} {int}, -places => $places; 51 | my $places_pattern_signed = make_test "Integer pattern", 52 | $RE {num} {int}, -places => $places, 53 | -sign => '[-+]'; 54 | 55 | $patterns {$places} = [$places_pattern, $places_pattern_signed]; 56 | } 57 | 58 | my @numbers; 59 | 60 | push @numbers => map {"0" x $_} 1 .. ($places [-1] + 1); 61 | push @numbers => qw [ 62 | 921092 1230981409 1239801 12034009123 120381409 12 098213470 63 | 289341728912098510298571873824712384 129834701 1098240 12349 64 | 3475 897465121 992342199123499195 999999999 12481 598134 23418 65 | 98214510814580 891274102981829570918 981243 1928411 912834 66 | ]; 67 | 68 | 69 | foreach my $number (@numbers) { 70 | my $length = length $number; 71 | foreach my $places (@places) { 72 | my ($pattern, $signed_pattern) = @{$patterns {$places}}; 73 | if ($length < $places) { 74 | my $reason = "Number too short"; 75 | foreach my $subj ($number, "-$number") { 76 | $pattern -> no_match ($subj, reason => $reason); 77 | $signed_pattern -> no_match ($subj, reason => $reason); 78 | } 79 | } 80 | elsif ($length > $places) { 81 | my $reason = "Number too long"; 82 | foreach my $subj ($number, "+$number") { 83 | $pattern -> no_match ($subj, reason => $reason); 84 | $signed_pattern -> no_match ($subj, reason => $reason); 85 | } 86 | } 87 | else { 88 | $pattern -> match ($number, [$number, "", $number], 89 | test => "Exact length"); 90 | $signed_pattern 91 | -> no_match ($number, reason => "Number not signed"); 92 | 93 | $pattern -> match ("-$number", ["-$number", "-", $number], 94 | test => "Exact length, signed (-)"); 95 | $signed_pattern -> match ("-$number", ["-$number", "-", $number], 96 | test => "Exact length, signed (-)"); 97 | 98 | $pattern -> match ("+$number", ["+$number", "+", $number], 99 | test => "Exact length, signed (+)"); 100 | $signed_pattern -> match ("+$number", ["+$number", "+", $number], 101 | test => "Exact length, signed (+)"); 102 | } 103 | } 104 | } 105 | 106 | done_testing (); 107 | 108 | 109 | __END__ 110 | -------------------------------------------------------------------------------- /t/zip/112_australia.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use Regexp::Common; 8 | use Test::More; 9 | 10 | my $r = eval "require Test::Regexp; 1"; 11 | 12 | unless ($r) { 13 | print "1..0 # SKIP Test::Regexp not found\n"; 14 | exit; 15 | } 16 | 17 | my $Test = Test::Regexp:: -> new -> init ( 18 | pattern => $RE {zip} {Australia}, 19 | keep_pattern => $RE {zip} {Australia} {-keep}, 20 | name => "Australian zip codes", 21 | ); 22 | 23 | my $Test_none = Test::Regexp:: -> new -> init ( 24 | pattern => $RE {zip} {Australia} {-prefix => 'no'}, 25 | keep_pattern => $RE {zip} {Australia} {-prefix => 'no'} {-keep}, 26 | name => "Australian zip codes (no prefix allowed)", 27 | ); 28 | 29 | my $Test_iso = Test::Regexp:: -> new -> init ( 30 | pattern => $RE {zip} {Australia} {-prefix => 'yes'} 31 | {-country => 'iso'}, 32 | keep_pattern => $RE {zip} {Australia} {-prefix => 'yes'} 33 | {-country => 'iso'} {-keep}, 34 | name => "Australian zip codes (ISO prefix required)", 35 | ); 36 | 37 | my $Test_cept = Test::Regexp:: -> new -> init ( 38 | pattern => $RE {zip} {Australia} {-prefix => 'yes'} 39 | {-country => 'cept'}, 40 | keep_pattern => $RE {zip} {Australia} {-prefix => 'yes'} 41 | {-country => 'cept'} {-keep}, 42 | name => "Australian zip codes (CEPT prefix required)", 43 | ); 44 | 45 | my @valid = ("0909", 1445, 3500, 9726); # Some selection. 46 | 47 | my $ISO = "AU"; 48 | my $CEPT = "AUS"; 49 | 50 | foreach my $zip (@valid) { 51 | # 52 | # No prefix 53 | # 54 | $Test -> match ($zip, 55 | [$zip, undef, $zip], 56 | test => "No prefix"); 57 | $Test_none -> match ($zip, 58 | [$zip, undef, $zip], 59 | test => "No prefix"); 60 | $Test_iso -> no_match ($zip, reason => "No prefix present"); 61 | $Test_cept -> no_match ($zip, reason => "No prefix present"); 62 | 63 | # 64 | # Can we prefix the zip code? 65 | # 66 | my $zip_iso = "$ISO-$zip"; 67 | my $zip_cept = "$CEPT-$zip"; 68 | 69 | # 70 | # ISO prefix 71 | # 72 | $Test -> match ($zip_iso, 73 | [$zip_iso, $ISO, $zip], 74 | test => "Use ISO prefix"); 75 | $Test_none -> no_match ($zip_iso, reason => "Prefix used"); 76 | $Test_iso -> match ($zip_iso, 77 | [$zip_iso, $ISO, $zip], 78 | test => "Use ISO prefix"); 79 | $Test_cept -> no_match ($zip_iso, reason => "ISO prefix used"); 80 | 81 | # 82 | # CEPT prefix 83 | # 84 | $Test -> match ($zip_cept, 85 | [$zip_cept, $CEPT, $zip], 86 | test => "Use CEPT prefix"); 87 | $Test_none -> no_match ($zip_cept, reason => "Prefix used"); 88 | $Test_iso -> no_match ($zip_cept, reason => "CEPT prefix used"); 89 | $Test_cept -> match ($zip_cept, 90 | [$zip_cept, $CEPT, $zip], 91 | test => "Use CEPT prefix"); 92 | 93 | # 94 | # An illegal prefix should never match 95 | # 96 | my $zip_illegal = "DE-$zip"; 97 | $Test -> no_match ($zip_illegal, reason => "Illegal prefix used"); 98 | $Test_none -> no_match ($zip_illegal, reason => "Illegal prefix used"); 99 | $Test_iso -> no_match ($zip_illegal, reason => "Illegal prefix used"); 100 | $Test_cept -> no_match ($zip_illegal, reason => "Illegal prefix used"); 101 | } 102 | 103 | 104 | done_testing; 105 | -------------------------------------------------------------------------------- /t/URI/wais.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common; 8 | 9 | $^W = 1; 10 | 11 | 12 | sub create_parts; 13 | 14 | my $wais = $RE {URI} {WAIS}; 15 | 16 | # No point in crosschecking, URI creation is tag independent. 17 | my @tests = ( 18 | [wais => $wais => {wais => NORMAL_PASS | FAIL}], 19 | ); 20 | 21 | my ($good, $bad) = create_parts; 22 | 23 | run_tests version => "Regexp::Common::URI::wais", 24 | tests => \@tests, 25 | good => $good, 26 | bad => $bad, 27 | query => \&wais, 28 | wanted => \&wanted, 29 | filter => \&filter, 30 | filter_passes => \&filter_passes, 31 | ; 32 | 33 | sub wais { 34 | my ($tag, $host, $port, $database, $search, $wtype, $wpath) = 35 | ($_ [0], @{$_ [1]}); 36 | 37 | my $wais = "wais://"; 38 | $wais .= $host if defined $host; 39 | $wais .= ":$port" if defined $port; 40 | $wais .= "/$database" if defined $database; 41 | $wais .= "?$search" if defined $search; 42 | $wais .= "/$wtype" if defined $wtype; 43 | $wais .= "/$wpath" if defined $wpath; 44 | 45 | $wais; 46 | } 47 | 48 | sub wanted { 49 | my ($tag, $parts) = @_; 50 | 51 | my @wanted; 52 | $wanted [0] = $_; 53 | $wanted [1] = "wais"; 54 | $wanted [2] = $$parts [0]; # host. 55 | $wanted [3] = $$parts [1]; # port. 56 | $wanted [4] = $$parts [2]; # database. 57 | $wanted [4] .= "?" . $$parts [3] if defined $$parts [3]; 58 | $wanted [4] .= "/" . $$parts [4] if defined $$parts [4]; 59 | $wanted [4] .= "/" . $$parts [5] if defined $$parts [5]; 60 | $wanted [5] = $$parts [2]; # database. 61 | $wanted [6] = undef; 62 | $wanted [6] .= "?" . $$parts [3] if defined $$parts [3]; 63 | $wanted [6] .= "/" . $$parts [4] if defined $$parts [4]; 64 | $wanted [6] .= "/" . $$parts [5] if defined $$parts [5]; 65 | $wanted [7] = $$parts [3]; # search. 66 | $wanted [8] = $$parts [4]; # wtype. 67 | $wanted [9] = $$parts [5]; # wpath. 68 | 69 | \@wanted; 70 | } 71 | 72 | 73 | sub create_parts { 74 | my (@good, @bad); 75 | 76 | # Hosts. 77 | # Host/ports are tested with other URIs as well, we're not using 78 | # all the combinations here. 79 | $good [0] = [qw /www.abigail.freedom.nl 127.0.0.1 w--w--w3.ABIGAIL.nl/]; 80 | $bad [0] = [qw /www.example..com w+w.example.com 127.0.0.0.1/]; 81 | 82 | # Ports. 83 | $good [1] = [undef, 210]; 84 | $bad [1] = ["", qw /: port/]; 85 | 86 | # Database 87 | $good [2] = ["", qw /database 0/, '%00%FF-!*,']; 88 | $bad [2] = [undef, qw /~/]; 89 | 90 | # Search 91 | $good [3] = [undef, "", qw /database 0/, '%00%FF-!*,']; 92 | $bad [3] = [qw {~ []}]; 93 | 94 | # Wtype 95 | $good [4] = [undef, "", qw /wtype 0/, '%00%FF-!*,']; 96 | $bad [4] = [qw {~ []}]; 97 | 98 | # Wpath 99 | $good [5] = [undef, "", qw /wpath 0/, '%00%FF-!*,']; 100 | $bad [5] = [qw {~ []}]; 101 | 102 | return (\@good, \@bad); 103 | } 104 | 105 | sub filter_passes { 106 | # Good URIs have either both a wtype and a wpath, or none at all. 107 | return 0 if defined $_ [0] -> [4] xor defined $_ [0] -> [5]; 108 | return 1; 109 | } 110 | 111 | sub filter { 112 | # At most one of 'search' and 'wtype/wpath' should be defined. 113 | return 0 if defined $_ [0] -> [3] && (defined $_ [0] -> [4] || 114 | defined $_ [0] -> [5]); 115 | 116 | return 0 if !defined $_ [0] -> [2] && grep {defined} @{$_ [0]} [3 .. 5]; 117 | 118 | return 1; 119 | } 120 | 121 | 122 | __END__ 123 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI; 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Exporter (); 10 | 11 | our @ISA = qw /Exporter/; 12 | our @EXPORT_OK = qw /register_uri/; 13 | 14 | use Regexp::Common qw /pattern clean no_defaults/; 15 | 16 | our $VERSION = '2024080801'; 17 | 18 | # Use 'require' here, not 'use', so we delay running them after we are compiled. 19 | # We also do it using an 'eval'; this saves us from have repeated similar 20 | # lines. The eval is further explained in 'perldoc -f require'. 21 | my @uris = qw /fax file ftp gopher http pop prospero news tel telnet tv wais/; 22 | foreach my $uri (@uris) { 23 | eval "require Regexp::Common::URI::$uri"; 24 | die $@ if $@; 25 | } 26 | 27 | my %uris; 28 | 29 | sub register_uri { 30 | my ($scheme, $uri) = @_; 31 | $uris {$scheme} = $uri; 32 | } 33 | 34 | pattern name => [qw (URI)], 35 | create => sub {my $uri = join '|' => values %uris; 36 | $uri =~ s/\(\?k:/(?:/g; 37 | "(?k:$uri)"; 38 | }, 39 | ; 40 | 41 | 1; 42 | 43 | __END__ 44 | 45 | =pod 46 | 47 | =head1 NAME 48 | 49 | Regexp::Common::URI -- provide patterns for URIs. 50 | 51 | =head1 SYNOPSIS 52 | 53 | use Regexp::Common qw /URI/; 54 | 55 | while (<>) { 56 | /$RE{URI}{HTTP}/ and print "Contains an HTTP URI.\n"; 57 | } 58 | 59 | =head1 DESCRIPTION 60 | 61 | Patterns for the following URIs are supported: fax, file, FTP, gopher, 62 | HTTP, news, NTTP, pop, prospero, tel, telnet, tv and WAIS. 63 | Each is documented in the I>, 64 | manual page, for the appropriate scheme (in lowercase), except for 65 | I URIs which are found in I. 66 | 67 | =head2 C<$RE{URI}> 68 | 69 | Return a pattern that recognizes any of the supported URIs. With 70 | C<{-keep}>, only the entire URI is returned (in C<$1>). 71 | 72 | =head1 REFERENCES 73 | 74 | =over 4 75 | 76 | =item B<[DRAFT-URI-TV]> 77 | 78 | Zigmond, D. and Vickers, M: I. December 2000. 80 | 81 | =item B<[DRAFT-URL-FTP]> 82 | 83 | Casey, James: I. November 1996. 84 | 85 | =item B<[RFC 1035]> 86 | 87 | Mockapetris, P.: I. 88 | November 1987. 89 | 90 | =item B<[RFC 1738]> 91 | 92 | Berners-Lee, Tim, Masinter, L., McCahill, M.: I. December 1994. 94 | 95 | =item B<[RFC 2396]> 96 | 97 | Berners-Lee, Tim, Fielding, R., and Masinter, L.: I. August 1998. 99 | 100 | =item B<[RFC 2616]> 101 | 102 | Fielding, R., Gettys, J., Mogul, J., Frystyk, H., Masinter, L., 103 | Leach, P. and Berners-Lee, Tim: I. 104 | June 1999. 105 | 106 | =item B<[RFC 2806]> 107 | 108 | Vaha-Sipila, A.: I. April 2000. 109 | 110 | =back 111 | 112 | =head1 SEE ALSO 113 | 114 | L for a general description of how to use this interface. 115 | 116 | =head1 AUTHOR 117 | 118 | Damian Conway (damian@conway.org) 119 | 120 | =head1 MAINTENANCE 121 | 122 | This package is maintained by Abigail S<(I)>. 123 | 124 | =head1 BUGS AND IRRITATIONS 125 | 126 | Bound to be plenty. 127 | 128 | For a start, there are many common regexes missing. 129 | Send them in to I. 130 | 131 | =head1 LICENSE and COPYRIGHT 132 | 133 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 134 | 135 | This module is free software, and maybe used under any of the following 136 | licenses: 137 | 138 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 139 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 140 | 3) The BSD License. See the file COPYRIGHT.BSD. 141 | 4) The MIT License. See the file COPYRIGHT.MIT. 142 | 143 | =cut 144 | -------------------------------------------------------------------------------- /t/number/131_integer_sep.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use Regexp::Common; 8 | use Test::More; 9 | 10 | my $r = eval "require Test::Regexp; 1"; 11 | 12 | unless ($r) { 13 | print "1..0 # SKIP Test::Regexp not found\n"; 14 | exit; 15 | } 16 | 17 | sub make_test { 18 | my ($name, $base, @options) = @_; 19 | my $pat = $base; 20 | while (@options) { 21 | my $opt = shift @options; 22 | if (@options && $options [0] !~ /^-/) { 23 | my $val = shift @options; 24 | $pat = $$pat {$opt => $val}; 25 | $name .= ", $opt => $val"; 26 | } 27 | else { 28 | $pat = $$pat {$opt}; 29 | $name .= ", $opt"; 30 | } 31 | } 32 | my $keep = $$pat {-keep}; 33 | Test::Regexp:: -> new -> init ( 34 | pattern => $pat, 35 | keep_pattern => $keep, 36 | name => $name, 37 | ); 38 | } 39 | 40 | my $pattern_c = make_test "Integer pattern" => $RE {num} {int}, 41 | -sep => ","; 42 | my $pattern_u = make_test "Integer pattern" => $RE {num} {int}, 43 | -sep => "_"; 44 | 45 | my @pass_numbers = qw [ 46 | 0 00 000 123 45 6 47 | 123,456 78,901 2,345 48 | 0,000,000,000,000,000,000,000,000,000,000,000,000 49 | 00,000,000,000,000,000,000,000,000,000,000,000,000 50 | 000,000,000,000,000,000,000,000,000,000,000,000,000 51 | 5,098,145,984,398,345 2,831,471,982 38,247,113,284,912 7,312,834 52 | 8,732,123,847,132 45,884,573 99,234,759,141 27,348,134,581 214,357,191 53 | ]; 54 | 55 | 56 | foreach my $number (@pass_numbers) { 57 | my $sep_c = $number =~ y/,/,/; 58 | my $test = $sep_c == 0 ? "No separator" 59 | : $sep_c == 1 ? "Single separator" 60 | : "Multiple separators"; 61 | $pattern_c -> match ( $number => [ $number, "", $number], 62 | test => $test); 63 | $pattern_c -> match ("-$number" => ["-$number", "-", $number], 64 | test => "$test, signed (-)"); 65 | $pattern_c -> match ("+$number" => ["+$number", "+", $number], 66 | test => "$test, signed (+)"); 67 | 68 | $number =~ s/,/_/g; 69 | $pattern_u -> match ( $number => [ $number, "", $number], 70 | test => $test); 71 | $pattern_u -> match ("-$number" => ["-$number", "-", $number], 72 | test => "$test, signed (-)"); 73 | $pattern_u -> match ("+$number" => ["+$number", "+", $number], 74 | test => "$test, signed (+)"); 75 | } 76 | 77 | 78 | my @failures = ( 79 | ["Wrong separator" => qw [0.000 1,234_456,789], "100 123"], 80 | ["Leading separator" => qw [,123 ,456,789]], 81 | ["Trailing separator" => qw [123, 456,789,]], 82 | ["Double separator" => qw [0,,000 123,456,,789]], 83 | ["No digits" => qw [, ,,]], 84 | ["Wrong number of digits in group" 85 | => qw [1,23,456 1,2345,678 489,1234,345,169,000]], 86 | ["Wrong number of digits in last group" 87 | => qw [123,4567 456,78]], 88 | ["Too many leading digits" 89 | => qw [1234,567 0000,000,000 8129132412341,000]], 90 | ["Trailing garbage" => qw [123,456,789foo 000,bar], "123,456 ", 91 | "987,543,611\n"], 92 | ["Leading garbage" => qw [baz,123,456 qux,000], " 123,456"], 93 | ["Inner garbage" => qw [123,foo,456 1a3,456], "123, 456"], 94 | ["Empty string" => ""], 95 | ["Garbage" => "wibble", "\n", "foo,123,bar"], 96 | ); 97 | 98 | foreach my $failure (@failures) { 99 | my ($reason, @subjects) = @$failure; 100 | foreach my $subject (@subjects) { 101 | $pattern_c -> no_match ($subject, reason => $reason); 102 | } 103 | } 104 | 105 | 106 | 107 | done_testing (); 108 | 109 | 110 | __END__ 111 | -------------------------------------------------------------------------------- /t/URI/gopher.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common; 7 | use t::Common; 8 | 9 | $^W = 1; 10 | 11 | 12 | sub create_parts; 13 | 14 | my $gopher = $RE {URI} {gopher}; 15 | my $gopher_notab = $RE {URI} {gopher} {-notab}; 16 | 17 | # No point in crosschecking, URI creation is tag independent. 18 | my @tests = ( 19 | [gopher => $gopher => {gopher => NORMAL_PASS | FAIL}], 20 | [gopher_notab => $gopher_notab => {gopher_notab => NORMAL_PASS | FAIL}], 21 | ); 22 | 23 | my ($good, $bad) = create_parts; 24 | 25 | run_tests version => "Regexp::Common::URI::gopher", 26 | tests => \@tests, 27 | good => $good, 28 | bad => $bad, 29 | query => \&gopher, 30 | wanted => \&wanted, 31 | filter => \&filter, 32 | ; 33 | 34 | sub gopher { 35 | my ($tag, $host, $port, $gtype, $selector, $search, $gopherplus_string) = 36 | ($_ [0], @{$_ [1]}); 37 | 38 | my $gopher = "gopher://"; 39 | $gopher .= $host if defined $host; 40 | $gopher .= ":$port" if defined $port; 41 | $gopher .= "/$gtype" if defined $gtype; 42 | $gopher .= $selector if defined $selector; 43 | $gopher .= "%09$search" if defined $search; 44 | $gopher .= "%09$gopherplus_string" if defined $gopherplus_string; 45 | 46 | $gopher; 47 | } 48 | 49 | sub wanted { 50 | my ($tag, $parts) = @_; 51 | 52 | my @wanted; 53 | $wanted [0] = $_; 54 | $wanted [1] = "gopher"; 55 | $wanted [2] = $$parts [0]; # host. 56 | $wanted [3] = $$parts [1]; # port. 57 | $wanted [4] = join "" => grep {defined} @$parts [2, 3]; 58 | $wanted [4] .= "%09" . $$parts [4] if defined $$parts [4]; 59 | $wanted [4] .= "%09" . $$parts [5] if defined $$parts [5]; 60 | $wanted [5] = $$parts [2]; # gtype. 61 | 62 | if ($tag eq 'gopher_notab') { 63 | $wanted [6] = $$parts [3]; # selector. 64 | $wanted [7] = $$parts [4]; # search. 65 | $wanted [8] = $$parts [5]; # gopherplus_string. 66 | } 67 | else { 68 | $wanted [6] = join "%09" => grep {defined} @$parts [3, 4, 5]; 69 | } 70 | 71 | \@wanted; 72 | } 73 | 74 | 75 | sub create_parts { 76 | my (@good, @bad); 77 | 78 | local $^W = 0; 79 | 80 | # Hosts. 81 | # Host/ports are tested with other URIs as well, we're not using 82 | # all the combinations here. 83 | $good [0] = [qw /www.abigail.freedom.nl 127.0.0.1 w--w--w3.ABIGAIL.nl/]; 84 | $bad [0] = [qw /www.example..com w+w.example.com 127.0.0.0.1/]; 85 | 86 | # Ports. 87 | $good [1] = [undef, 70]; 88 | $bad [1] = ["", qw /: port/]; 89 | 90 | # Gtype 91 | # No need for both "" and 'undef' in the bad part here - they will 92 | # result in the same URI. 93 | $good [2] = [qw /0 + T/]; 94 | $bad [2] = ["", qw /~/]; 95 | 96 | # Selector 97 | # Don't use an 'undef' here. It will create the same URI as for 98 | # the empty string, but {-keep} will return "". 99 | $good [3] = ["", qw {FNURD 0}, q {$_.+!*'(),:@&=%FF}]; 100 | $bad [3] = [qw {/ []}]; 101 | 102 | # Search 103 | $good [4] = [undef, "", qw {FNORD 0}, q {$_.+!*'(),:@&=%FF}]; 104 | $bad [4] = [qw {/ []}]; 105 | 106 | # Gopherplus string 107 | $good [5] = [undef, "", qw {fnord 0}, q {$_.+%09!*'(),:@&=%FF}]; 108 | $bad [5] = [qw {/ []}]; 109 | 110 | return (\@good, \@bad); 111 | } 112 | 113 | 114 | sub filter { 115 | # Disallow defined gopherplus strings if search is undefined. 116 | return 0 if defined $_ [0] -> [5] && !defined $_ [0] -> [4]; 117 | 118 | # If the gtype is "", but the selector starts with a char that's 119 | # a valid gtype, we'll see a match where we'd expect a failure. 120 | return 0 if $_ [0] -> [2] eq "" && defined $_ [0] -> [3] 121 | && $_ [0] -> [3] =~ /^[0-9+IgT]/; 122 | return 1; 123 | } 124 | 125 | 126 | __END__ 127 | -------------------------------------------------------------------------------- /t/test_balanced.t: -------------------------------------------------------------------------------- 1 | # VOODOO LINE-NOISE 2 | my($C,$M,$P,$N,$S);END{print"1..$C\n$M";print"\nfailed: $N\n"if$N} 3 | sub ok{$C++; $M.= ($_[0]||!@_)?"ok $C\n":($N++,"not ok $C (". 4 | ((caller 1)[1]||(caller 0)[1]).":".((caller 1)[2]||(caller 0)[2]).")\n")} 5 | sub try{$P=qr/^$_[0]$/}sub fail{ok($S=$_[0]!~$P)}sub pass{ok($S=$_[0]=~$P)} 6 | 7 | # LOAD 8 | 9 | use Regexp::Common; 10 | ok; 11 | 12 | # SIMPLE BALANCING ACT 13 | 14 | try $RE{balanced}; 15 | 16 | pass "()"; 17 | pass "(a)"; 18 | pass "(a b)"; 19 | pass "(a()b)"; 20 | pass "(a( )b)"; 21 | pass "(a(b))"; 22 | pass "(a(b)(c)(d(e)))"; 23 | pass "(a(])b)"; 24 | pass "(a({{{)b)"; 25 | fail "("; 26 | fail "(a"; 27 | fail "(a(b)"; 28 | fail "(a( b)"; 29 | fail "(a(]b)"; 30 | fail "(a({{{)b"; 31 | 32 | 33 | # MULTIPLE BALANCING ACT 34 | 35 | try $RE{balanced}{-parens=>"()[]"}; 36 | 37 | pass "()"; 38 | pass "(a)"; 39 | pass "(a b)"; 40 | pass "(a()b)"; 41 | pass "(a( )b)"; 42 | pass "(a(b))"; 43 | pass "(a(b)(c)(d(e)))"; 44 | pass "(a(})b)"; 45 | pass "(a([[()]])b)"; 46 | fail "("; 47 | fail "(a"; 48 | fail "(a(b)"; 49 | fail "(a( b)"; 50 | fail "(a(]b)"; 51 | fail "(a([[[)b"; 52 | 53 | 54 | try $RE{balanced}{-begin => 'begin'}{-end => 'end'}; 55 | 56 | pass 'begin end'; 57 | fail 'begin en'; 58 | fail 'begin nd'; 59 | pass 'begin begin end end'; 60 | pass 'beginend'; 61 | pass 'beginbeginbeginendendend'; 62 | pass 'begin begin end begin begin end begin end end end'; 63 | fail 'begin begin end begin egin end begin end end end'; 64 | fail 'begin end begin end'; 65 | 66 | try $RE{balanced}{-begin => 'start'}{-end => 'stop'}; 67 | 68 | pass 'start stop'; 69 | fail 'start st'; 70 | fail 'start op'; 71 | pass 'start start stop stop'; 72 | pass 'startstop'; 73 | pass 'startstartstartstopstopstop'; 74 | pass 'start start stop start start stop start stop stop stop'; 75 | fail 'start start stop start tart stop start stop stop stop'; 76 | fail 'start stop start stop'; 77 | 78 | try $RE{balanced}{-parens => '()[]'}{-begin => 'start'}{-end => 'stop'}; 79 | 80 | pass 'start stop'; 81 | fail 'start st'; 82 | fail 'start op'; 83 | pass 'start start stop stop'; 84 | pass 'startstop'; 85 | pass 'startstartstartstopstopstop'; 86 | pass 'start start stop start start stop start stop stop stop'; 87 | fail 'start start stop start tart stop start stop stop stop'; 88 | fail 'start stop start stop'; 89 | 90 | try $RE{balanced}{-begin => 'S'}{-end => 'T'}; 91 | 92 | pass 'S T'; 93 | fail 'S Q'; 94 | pass 'S S T T'; 95 | pass 'ST'; 96 | pass 'SSSTTT'; 97 | pass 'S S T S S T S T T T'; 98 | fail 'S S T S Q T S T T T'; 99 | fail 'S T S T'; 100 | 101 | try $RE{balanced}{-start => "(|["}{-end => ")|]"}; 102 | 103 | pass "()"; 104 | pass "(a)"; 105 | pass "(a b)"; 106 | pass "(a()b)"; 107 | pass "(a( )b)"; 108 | pass "(a(b))"; 109 | pass "(a(b)(c)(d(e)))"; 110 | pass "(a(})b)"; 111 | pass "(a([[()]])b)"; 112 | fail "("; 113 | fail "(a"; 114 | fail "(a(b)"; 115 | fail "(a( b)"; 116 | fail "(a(]b)"; 117 | fail "(a([[[)b"; 118 | 119 | # Test '|' delimiters. 120 | 121 | try $RE{balanced}{-begin => '\|'}{-end => '-'}; 122 | 123 | pass '| -'; 124 | fail '| Q'; 125 | pass '| | - -'; 126 | pass '|-'; 127 | pass '|||---'; 128 | pass '| | - | | - | - - -'; 129 | fail '| | - | Q - | - - -'; 130 | fail '| - | -'; 131 | 132 | try $RE{balanced}{-begin => '!'}{-end => '\|'}; 133 | 134 | pass '! |'; 135 | fail '! Q'; 136 | pass '! ! | |'; 137 | pass '!|'; 138 | pass '!!!|||'; 139 | pass '! ! | ! ! | ! | | |'; 140 | fail '! ! | ! Q | ! | | |'; 141 | fail '! | ! |'; 142 | 143 | try $RE{balanced}{-begin => '\||['} {-end => ')|]'}; 144 | 145 | pass "|)"; 146 | pass "|a)"; 147 | pass "|a b)"; 148 | pass "|a|)b)"; 149 | pass "|a| )b)"; 150 | pass "|a|b))"; 151 | pass "|a|b)|c)|d|e)))"; 152 | pass "|a|})b)"; 153 | pass "|a|[[|)]])b)"; 154 | fail "|"; 155 | fail "|a"; 156 | fail "|a|b)"; 157 | fail "|a| b)"; 158 | fail "|a|]b)"; 159 | fail "|a|[[[)b"; 160 | 161 | try $RE{balanced}{-begin => '(|['}{-end => ']'}; 162 | 163 | pass "(]"; 164 | pass "(a]"; 165 | pass "(a b]"; 166 | pass "(a(]b]"; 167 | pass "(a( ]b]"; 168 | pass "(a(b]]"; 169 | pass "(a(b](c](d(e]]]"; 170 | pass "(a(}]b]"; 171 | pass "(a([[(]]]]b]"; 172 | fail "("; 173 | fail "(a"; 174 | fail "(a(b]"; 175 | fail "(a( b]"; 176 | pass "(a(]b]"; 177 | fail "(a([[[]b"; 178 | 179 | -------------------------------------------------------------------------------- /lib/Regexp/Common/SEN.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::SEN; 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Regexp::Common qw /pattern clean no_defaults/; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | =begin does_not_exist 14 | 15 | sub par11 { 16 | my $string = shift; 17 | my $sum = 0; 18 | for my $i (0 .. length ($string) - 1) { 19 | my $c = substr ($string, $i, 1); 20 | $sum += $c * (length ($string) - $i) 21 | } 22 | !($sum % 11) 23 | } 24 | 25 | =end does_not_exist 26 | =cut 27 | 28 | # http://www.ssa.gov/history/ssn/geocard.html 29 | pattern name => [qw /SEN USA SSN -sep=-/], 30 | create => sub { 31 | my $sep = $_ [1] {-sep}; 32 | "(?k:(?k:[1-9][0-9][0-9]|0[1-9][0-9]|00[1-9])$sep" . 33 | "(?k:[1-9][0-9]|0[1-9])$sep" . 34 | "(?k:[1-9][0-9][0-9][0-9]|0[1-9][0-9][0-9]|" . 35 | "00[1-9][0-9]|000[1-9]))" 36 | }, 37 | ; 38 | 39 | =begin does_not_exist 40 | 41 | It's not clear whether this is the right checksum. 42 | 43 | # http://www.google.nl/search?q=cache:8m1zKNYrEO0J:www.enschede.nl/nieuw/projecten/aanbesteding/integratie/pve%2520Bijlage%25207.5.doc+Sofi+nummer+formaat&hl=en&start=56&lr=lang_en|lang_nl&ie=UTF-8 44 | pattern name => [qw /SEN Netherlands SoFi/], 45 | create => sub { 46 | # 9 digits (d1 d2 d3 d4 d5 d6 d7 d8 d9) 47 | # 9*d1 + 8*d2 + 7*d3 + 6*d4 + 5*d5 + 4*d6 + 3*d7 + 2*d8 + 1*d9 48 | # == 0 mod 11. 49 | qr /([0-9]{9})(?(?{par11 ($^N)})|(?!))/; 50 | } 51 | ; 52 | 53 | =end does_not_exist 54 | =cut 55 | 56 | 1; 57 | 58 | __END__ 59 | 60 | =pod 61 | 62 | =head1 NAME 63 | 64 | Regexp::Common::SEN -- provide regexes for Social-Economical Numbers. 65 | 66 | =head1 SYNOPSIS 67 | 68 | use Regexp::Common qw /SEN/; 69 | 70 | while (<>) { 71 | /^$RE{SEN}{USA}{SSN}$/ and print "Social Security Number\n"; 72 | } 73 | 74 | 75 | =head1 DESCRIPTION 76 | 77 | Please consult the manual of L for a general description 78 | of the works of this interface. 79 | 80 | Do not use this module directly, but load it via I. 81 | 82 | =head2 C<$RE{SEN}{USA}{SSN}{-sep}> 83 | 84 | Returns a pattern that matches an American Social Security Number (SSN). 85 | SSNs consist of three groups of numbers, separated by a hyphen (C<->). 86 | This pattern only checks for a valid structure, that is, it validates 87 | whether a number is valid SSN, was a valid SSN, or maybe a valid SSN 88 | in the future. There are almost a billion possible SSNs, and about 89 | 400 million are in use, or have been in use. 90 | 91 | If C<-sep=I

> is specified, the pattern I

is used as the 92 | separator between the groups of numbers. 93 | 94 | Under C<-keep> (see L): 95 | 96 | =over 4 97 | 98 | =item $1 99 | 100 | captures the entire SSN. 101 | 102 | =item $2 103 | 104 | captures the first group of digits (the area number). 105 | 106 | =item $3 107 | 108 | captures the second group of digits (the group number). 109 | 110 | =item $4 111 | 112 | captures the third group of digits (the serial number). 113 | 114 | =back 115 | 116 | =head1 SEE ALSO 117 | 118 | L for a general description of how to use this interface. 119 | 120 | =head1 AUTHORS 121 | 122 | Damian Conway and Abigail. 123 | 124 | =head1 MAINTENANCE 125 | 126 | This package is maintained by Abigail S<(I)>. 127 | 128 | =head1 BUGS AND IRRITATIONS 129 | 130 | Bound to be plenty. 131 | 132 | For a start, there are many common regexes missing. 133 | Send them in to I. 134 | 135 | =head1 LICENSE and COPYRIGHT 136 | 137 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 138 | 139 | This module is free software, and maybe used under any of the following 140 | licenses: 141 | 142 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 143 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 144 | 3) The BSD License. See the file COPYRIGHT.BSD. 145 | 4) The MIT License. See the file COPYRIGHT.MIT. 146 | 147 | =cut 148 | -------------------------------------------------------------------------------- /t/number/122_integer_places.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | no warnings 'syntax'; 6 | 7 | use Regexp::Common; 8 | use Test::More; 9 | 10 | my $r = eval "require Test::Regexp; 1"; 11 | 12 | unless ($r) { 13 | print "1..0 # SKIP Test::Regexp not found\n"; 14 | exit; 15 | } 16 | 17 | 18 | sub make_test { 19 | my ($name, $base, @options) = @_; 20 | my $pat = $base; 21 | while (@options) { 22 | my $opt = shift @options; 23 | if (@options && $options [0] !~ /^-/) { 24 | my $val = shift @options; 25 | $pat = $$pat {$opt => $val}; 26 | $name .= ", $opt => $val"; 27 | } 28 | else { 29 | $pat = $$pat {$opt}; 30 | $name .= ", $opt"; 31 | } 32 | } 33 | my $keep = $$pat {-keep}; 34 | Test::Regexp:: -> new -> init ( 35 | pattern => $pat, 36 | keep_pattern => $keep, 37 | name => $name, 38 | ); 39 | } 40 | 41 | # 42 | # Patterns with variable places. 43 | # 44 | my @places = (1, 3, 8, 21, 34); 45 | 46 | my %patterns; 47 | 48 | for (my $i = 0; $i < @places; $i ++) { 49 | my $places1 = $places [$i]; 50 | for (my $j = $i + 1; $j < @places; $j ++) { 51 | my $places2 = $places [$j]; 52 | my $places = "$places1,$places2"; 53 | my $places_pattern = make_test "Integer pattern" => 54 | $RE {num} {int}, 55 | -places => $places; 56 | my $places_pattern_signed = make_test "Integer pattern" => 57 | $RE {num} {int}, 58 | -places => $places, 59 | -sign => '[-+]'; 60 | $patterns {$places1} 61 | {$places2} = [$places_pattern, $places_pattern_signed]; 62 | } 63 | } 64 | 65 | my @numbers; 66 | 67 | push @numbers => map {"0" x $_} 1 .. ($places [-1] + 1); 68 | push @numbers => qw [ 69 | 921092 1230981409 1239801 12034009123 120381409 12 098213470 70 | 289341728912098510298571873824712384 129834701 1098240 12349 71 | 3475 897465121 992342199123499195 999999999 12481 598134 23418 72 | 98214510814580 891274102981829570918 981243 1928411 912834 73 | ]; 74 | 75 | 76 | foreach my $number (@numbers) { 77 | my $length = length $number; 78 | for (my $i = 0; $i < @places; $i ++) { 79 | my $places1 = $places [$i]; 80 | for (my $j = $i + 1; $j < @places; $j ++) { 81 | my $places2 = $places [$j]; 82 | my ($pattern, $signed_pattern) = @{$patterns {$places1} {$places2}}; 83 | if ($length < $places1) { 84 | my $reason = "Number too short"; 85 | foreach my $subj ($number, "-$number") { 86 | $pattern -> no_match ($subj, reason => $reason); 87 | $signed_pattern -> no_match ($subj, reason => $reason); 88 | } 89 | } 90 | elsif ($length > $places2) { 91 | my $reason = "Number too long"; 92 | foreach my $subj ($number, "+$number") { 93 | $pattern -> no_match ($subj, reason => $reason); 94 | $signed_pattern -> no_match ($subj, reason => $reason); 95 | } 96 | } 97 | else { 98 | my $reason = "Length within bounds"; 99 | $pattern -> match ($number, [$number, "", $number], 100 | test => $reason); 101 | $signed_pattern 102 | -> no_match ($number, reason => "Number not signed"); 103 | 104 | $pattern -> match ("+$number", 105 | ["+$number", "+", $number], 106 | test => "$reason, signed (+)"); 107 | $signed_pattern -> match ("+$number", 108 | ["+$number", "+", $number], 109 | test => "$reason, signed (+)"); 110 | } 111 | } 112 | } 113 | } 114 | 115 | done_testing (); 116 | 117 | 118 | __END__ 119 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | ============================================================================== 2 | Release of version 2024080801 of Regexp::Common 3 | ============================================================================== 4 | 5 | IMPORTANT NOTICE: 6 | As of version 2016060101, we cease to support pre-5.10.0 perls. 7 | 5.10.0 was release over 8 years ago, and it just becomes too 8 | painful to support older perls. 9 | 10 | The main reason for version 2.122 is a change in the license. You now 11 | have the option to use this software under either the original Artistic 12 | License, the Artistic License 2.0, the MIT license, or the BSD license. 13 | 14 | 15 | WARNINGS: 16 | As of version 2016052801, $RE {delimited} and $RE {quoted} are 17 | no longer supported on pre-5.10 Perl.s 18 | 19 | As of version 2013030901, $RE {balanced} is no longer supported 20 | for pre-5.10 Perls. 21 | 22 | INCOMPATIBLE CHANGE in version 2.119: 23 | The $N settings for the -keep option of US postal codes 24 | ($RE {zip} {US} {-keep}) have been changed. See the 25 | Regexp::Common::zip for details. 26 | 27 | INCOMPATIBLE CHANGE in version 2.113: 28 | Regexp::Common used to set $; to '='. This no longer happens, 29 | because setting $; breaks Filter::Simple. This means that regexps 30 | of the form $RE{foo}{"-flag=value"} no longer work! They need 31 | to be written as $RE{foo}{"-flag$;value"} or as 32 | $RE{foo}{-flag => "value"}. 33 | 34 | When defining patterns using the pattern function, a = still 35 | needs to be used to separate the flag from its default value. 36 | This has not been changed. 37 | 38 | We are very sorry for the inconvenience. 39 | 40 | NAME 41 | 42 | Regexp::Common - Provide commonly requested regular expressions 43 | 44 | 45 | SYNOPSIS 46 | 47 | use Regexp::Common; 48 | 49 | while (<>) { 50 | /$RE{num}{real}/ 51 | and print q{a number\n}; 52 | /$RE{quoted}/ 53 | and print q{a ['"`] quoted string\n}; 54 | /$RE{delimited}{-delim=>'/'}/ 55 | and print q{a /.../ sequence\n}; 56 | /$RE{balanced}{-parens=>'()'}/ 57 | and print q{balanced parentheses\n}; 58 | /$RE{profanity}/ 59 | and print q{a #*@%-ing word\n}; 60 | } 61 | 62 | 63 | DESCRIPTION 64 | 65 | By default, this module exports a single hash (`%RE') that stores or 66 | generates commonly needed regular expressions. Patterns currently 67 | provided include: 68 | 69 | * balanced parentheses and brackets 70 | * delimited text (with escapes) 71 | * integers and floating-point numbers in any base (up to 36) 72 | * comments in 44 languages 73 | * offensive language 74 | * lists of any pattern 75 | * IPv4 addresses 76 | * URIs. 77 | * Zip codes. 78 | 79 | Future releases of the module will also provide patterns for the 80 | following: 81 | 82 | * email addresses 83 | * HTML/XML tags 84 | * mail headers (including multiline ones), 85 | * more URIs 86 | * telephone numbers of various countries 87 | * currency (universal 3 letter format, Latin-1, currency names) 88 | * dates 89 | * binary formats (e.g. UUencoded, MIMEd) 90 | * Credit card numbers. 91 | 92 | 93 | INSTALLATION 94 | 95 | It's all pure Perl, so just put the .pm files in their appropriate 96 | local Perl subdirectory. 97 | 98 | Alternatively, use the common approach: 99 | - untar the archive 100 | - run: perl Makefile.PL 101 | - run: make 102 | - run: make test 103 | - run: make install 104 | 105 | AUTHORS 106 | 107 | Damian Conway (damian@cs.monash.edu.au) and Abigail 108 | (regexp-common@abigail.freedom.nl) 109 | 110 | 111 | MAINTAINER 112 | 113 | Abigail (regexp-common@abigail.freedom.nl) 114 | 115 | 116 | COPYRIGHT and LICENSE 117 | 118 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 119 | 120 | This module is free software, and maybe used under any of the following 121 | licenses: 122 | 123 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 124 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 125 | 3) The BSD License. See the file COPYRIGHT.BSD. 126 | 4) The MIT License. See the file COPYRIGHT.MIT. 127 | 128 | ============================================================================== 129 | 130 | 131 | AVAILABILITY 132 | 133 | Regexp::Common has been uploaded to the CPAN and is also available from: 134 | 135 | http://github.com/Abigail/Regexp--Common.git 136 | 137 | ============================================================================== 138 | -------------------------------------------------------------------------------- /lib/Regexp/Common/profanity.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::profanity; 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Regexp::Common qw /pattern clean no_defaults/; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | my $profanity = '(?:cvff(?:\\ gnxr|\\-gnxr|gnxr|r(?:ef|[feq])|vat|l)?|dhvzf?|fuvg(?:g(?:r(?:ef|[qe])|vat|l)|r(?:ef|[fqel])|vat|[fr])?|g(?:heqf?|jngf?)|jnax(?:r(?:ef|[eq])|vat|f)?|n(?:ef(?:r(?:\\ ubyr|\\-ubyr|ubyr|[fq])|vat|r)|ff(?:\\ ubyrf?|\\-ubyrf?|rq|ubyrf?|vat))|o(?:hyy(?:\\ fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?|\\-fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?|fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?)|ybj(?:\\ wbof?|\\-wbof?|wbof?))|p(?:bpx(?:\\ fhpx(?:ref?|vat)|\\-fhpx(?:ref?|vat)|fhpx(?:ref?|vat))|enc(?:c(?:r(?:ef|[eq])|vat|l)|f)?|h(?:agf?|z(?:vat|zvat|f)))|qvpx(?:\\ urnq|\\-urnq|rq|urnq|vat|yrff|f)|s(?:hpx(?:rq|vat|f)?|neg(?:r[eq]|vat|[fl])?|rygpu(?:r(?:ef|[efq])|vat)?)|un(?:eq[\\-\\ ]?ba|ys(?:\\ n[fe]|\\-n[fe]|n[fe])frq)|z(?:bgure(?:\\ shpx(?:ref?|vat)|\\-shpx(?:ref?|vat)|shpx(?:ref?|vat))|hgu(?:n(?:\\ shpx(?:ref?|vat|[nnn])|\\-shpx(?:ref?|vat|[nnn])|shpx(?:ref?|vat|[nnn]))|re(?:\\ shpx(?:ref?|vat)|\\-shpx(?:ref?|vat)|shpx(?:ref?|vat)))|reqr?))'; 14 | 15 | my $contextual = '(?:c(?:bex|e(?:bax|vpxf?)|hff(?:vrf|l)|vff(?:\\ gnxr|\\-gnxr|gnxr|r(?:ef|[feq])|vat|l)?)|dhvzf?|ebbg(?:r(?:ef|[eq])|vat|f)?|f(?:bq(?:q(?:rq|vat)|f)?|chax|perj(?:rq|vat|f)?|u(?:nt(?:t(?:r(?:ef|[qe])|vat)|f)?|vg(?:g(?:r(?:ef|[qe])|vat|l)|r(?:ef|[fqel])|vat|[fr])?))|g(?:heqf?|jngf?|vgf?)|jnax(?:r(?:ef|[eq])|vat|f)?|n(?:ef(?:r(?:\\ ubyr|\\-ubyr|ubyr|[fq])|vat|r)|ff(?:\\ ubyrf?|\\-ubyrf?|rq|ubyrf?|vat))|o(?:ba(?:r(?:ef|[fe])|vat|r)|h(?:ttre|yy(?:\\ fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?|\\-fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?|fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?))|n(?:fgneq|yy(?:r(?:ef|[qe])|vat|f)?)|yb(?:bql|j(?:\\ wbof?|\\-wbof?|wbof?)))|p(?:bpx(?:\\ fhpx(?:ref?|vat)|\\-fhpx(?:ref?|vat)|fhpx(?:ref?|vat)|f)?|enc(?:c(?:r(?:ef|[eq])|vat|l)|f)?|h(?:agf?|z(?:vat|zvat|f)))|q(?:batf?|vpx(?:\\ urnq|\\-urnq|rq|urnq|vat|yrff|f)?)|s(?:hpx(?:rq|vat|f)?|neg(?:r[eq]|vat|[fl])?|rygpu(?:r(?:ef|[efq])|vat)?)|u(?:hzc(?:r(?:ef|[eq])|vat|f)?|n(?:eq[\\-\\ ]?ba|ys(?:\\ n[fe]|\\-n[fe]|n[fe])frq))|z(?:bgure(?:\\ shpx(?:ref?|vat)|\\-shpx(?:ref?|vat)|shpx(?:ref?|vat))|hgu(?:n(?:\\ shpx(?:ref?|vat|[nnn])|\\-shpx(?:ref?|vat|[nnn])|shpx(?:ref?|vat|[nnn]))|re(?:\\ shpx(?:ref?|vat)|\\-shpx(?:ref?|vat)|shpx(?:ref?|vat)))|reqr?))'; 16 | 17 | tr/A-Za-z/N-ZA-Mn-za-m/ foreach $profanity, $contextual; 18 | 19 | pattern name => [qw (profanity)], 20 | create => '(?:\b(?k:' . $profanity . ')\b)', 21 | ; 22 | 23 | pattern name => [qw (profanity contextual)], 24 | create => '(?:\b(?k:' . $contextual . ')\b)', 25 | ; 26 | 27 | 28 | 1; 29 | 30 | __END__ 31 | 32 | =pod 33 | 34 | =head1 NAME 35 | 36 | Regexp::Common::profanity -- provide regexes for profanity 37 | 38 | =head1 SYNOPSIS 39 | 40 | use Regexp::Common qw /profanity/; 41 | 42 | while (<>) { 43 | /$RE{profanity}/ and print "Contains profanity\n"; 44 | } 45 | 46 | 47 | =head1 DESCRIPTION 48 | 49 | Please consult the manual of L for a general description 50 | of the works of this interface. 51 | 52 | Do not use this module directly, but load it via I. 53 | 54 | =head2 $RE{profanity} 55 | 56 | Returns a pattern matching words -- such as Carlin's "big seven" -- that 57 | are most likely to give offense. Note that correct anatomical terms are 58 | deliberately I included in the list. 59 | 60 | Under C<-keep> (see L): 61 | 62 | =over 4 63 | 64 | =item $1 65 | 66 | captures the entire word 67 | 68 | =back 69 | 70 | =head2 C<$RE{profanity}{contextual}> 71 | 72 | Returns a pattern matching words that are likely to give offense when 73 | used in specific contexts, but which also have genuinely 74 | non-offensive meanings. 75 | 76 | Under C<-keep> (see L): 77 | 78 | =over 4 79 | 80 | =item $1 81 | 82 | captures the entire word 83 | 84 | =back 85 | 86 | =head1 SEE ALSO 87 | 88 | L for a general description of how to use this interface. 89 | 90 | =head1 AUTHOR 91 | 92 | Damian Conway (damian@conway.org) 93 | 94 | =head1 MAINTENANCE 95 | 96 | This package is maintained by Abigail S<(I)>. 97 | 98 | =head1 BUGS AND IRRITATIONS 99 | 100 | Bound to be plenty. 101 | 102 | For a start, there are many common regexes missing. 103 | Send them in to I. 104 | 105 | =head1 LICENSE and COPYRIGHT 106 | 107 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 108 | 109 | This module is free software, and maybe used under any of the following 110 | licenses: 111 | 112 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 113 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 114 | 3) The BSD License. See the file COPYRIGHT.BSD. 115 | 4) The MIT License. See the file COPYRIGHT.MIT. 116 | 117 | =cut 118 | -------------------------------------------------------------------------------- /lib/Regexp/Common/list.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::list; 2 | 3 | use 5.10.0; 4 | 5 | use strict; 6 | use warnings; 7 | no warnings 'syntax'; 8 | 9 | use Regexp::Common qw /pattern clean no_defaults/; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | sub gen_list_pattern { 14 | my ($pat, $sep, $lsep) = @_; 15 | $lsep = $sep unless defined $lsep; 16 | return "(?k:(?:(?:$pat)(?:$sep))*(?:$pat)(?k:$lsep)(?:$pat))"; 17 | } 18 | 19 | my $defpat = '.*?\S'; 20 | my $defsep = '\s*,\s*'; 21 | 22 | pattern name => ['list', "-pat=$defpat", "-sep=$defsep", '-lastsep'], 23 | create => sub {gen_list_pattern (@{$_[1]}{-pat, -sep, -lastsep})}, 24 | ; 25 | 26 | pattern name => ['list', 'conj', '-word=(?:and|or)'], 27 | create => sub {gen_list_pattern($defpat, $defsep, 28 | '\s*,?\s*'.$_[1]->{-word}.'\s*'); 29 | }, 30 | ; 31 | 32 | pattern name => ['list', 'and'], 33 | create => sub {gen_list_pattern ($defpat, $defsep, '\s*,?\s*and\s*')}, 34 | ; 35 | 36 | pattern name => ['list', 'or'], 37 | create => sub {gen_list_pattern ($defpat, $defsep, '\s*,?\s*or\s*')}, 38 | ; 39 | 40 | 41 | 1; 42 | 43 | __END__ 44 | 45 | =pod 46 | 47 | =head1 NAME 48 | 49 | Regexp::Common::list -- provide regexes for lists 50 | 51 | =head1 SYNOPSIS 52 | 53 | use Regexp::Common qw /list/; 54 | 55 | while (<>) { 56 | /$RE{list}{-pat => '\w+'}/ and print "List of words"; 57 | /$RE{list}{-pat => $RE{num}{real}}/ and print "List of numbers"; 58 | } 59 | 60 | 61 | =head1 DESCRIPTION 62 | 63 | Please consult the manual of L for a general description 64 | of the works of this interface. 65 | 66 | Do not use this module directly, but load it via I. 67 | 68 | =head2 C<$RE{list}{-pat}{-sep}{-lastsep}> 69 | 70 | Returns a pattern matching a list of (at least two) substrings. 71 | 72 | If C<-pat=I

> is specified, it defines the pattern for each substring 73 | in the list. By default, I

is C. In Regexp::Common 0.02 74 | or earlier, the default pattern was C. But that will match 75 | a single space, causing unintended parsing of C as a 76 | list of four elements instead of 3 (with C<-word> being C<(?:and)>). 77 | One consequence is that a list of the form "a,,b" will no longer be 78 | parsed. Use the pattern C to be able to parse this, but see 79 | the previous remark. 80 | 81 | If C<-sep=I

> is specified, it defines the pattern I

to be used as 82 | a separator between each pair of substrings in the list, except the final two. 83 | By default I

is C. 84 | 85 | If C<-lastsep=I

> is specified, it defines the pattern I

to be used as 86 | a separator between the final two substrings in the list. 87 | By default I

is the same as the pattern specified by the C<-sep> flag. 88 | 89 | For example: 90 | 91 | $RE{list}{-pat=>'\w+'} # match a list of word chars 92 | $RE{list}{-pat=>$RE{num}{real}} # match a list of numbers 93 | $RE{list}{-sep=>"\t"} # match a tab-separated list 94 | $RE{list}{-lastsep=>',\s+and\s+'} # match a proper English list 95 | 96 | Under C<-keep>: 97 | 98 | =over 4 99 | 100 | =item $1 101 | 102 | captures the entire list 103 | 104 | =item $2 105 | 106 | captures the last separator 107 | 108 | =back 109 | 110 | =head2 C<$RE{list}{conj}{-word=I}> 111 | 112 | An alias for C<< $RE{list}{-lastsep=>'\s*,?\s*I\s*'} >> 113 | 114 | If C<-word> is not specified, the default pattern is C. 115 | 116 | For example: 117 | 118 | $RE{list}{conj}{-word=>'et'} # match Jean, Paul, et Satre 119 | $RE{list}{conj}{-word=>'oder'} # match Bonn, Koln oder Hamburg 120 | 121 | =head2 C<$RE{list}{and}> 122 | 123 | An alias for C<< $RE{list}{conj}{-word=>'and'} >> 124 | 125 | =head2 C<$RE{list}{or}> 126 | 127 | An alias for C<< $RE{list}{conj}{-word=>'or'} >> 128 | 129 | =head1 SEE ALSO 130 | 131 | L for a general description of how to use this interface. 132 | 133 | =head1 AUTHOR 134 | 135 | Damian Conway (damian@conway.org) 136 | 137 | =head1 MAINTENANCE 138 | 139 | This package is maintained by Abigail S<(I)>. 140 | 141 | =head1 BUGS AND IRRITATIONS 142 | 143 | Bound to be plenty. 144 | 145 | For a start, there are many common regexes missing. 146 | Send them in to I. 147 | 148 | =head1 LICENSE and COPYRIGHT 149 | 150 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 151 | 152 | This module is free software, and maybe used under any of the following 153 | licenses: 154 | 155 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 156 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 157 | 3) The BSD License. See the file COPYRIGHT.BSD. 158 | 4) The MIT License. See the file COPYRIGHT.MIT. 159 | 160 | =cut 161 | -------------------------------------------------------------------------------- /t/number/decimal.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use lib qw {blib/lib}, "."; 5 | 6 | use Regexp::Common qw /RE_num_decimal/; 7 | use t::Common; 8 | 9 | my $decimal = $RE {num} {decimal}; 10 | 11 | # The following arrays contain valid numbers in the respective bases - 12 | # and the numbers aren't valid in the next array. 13 | my @data = ( 14 | [36 => [qw /regexp common perl5/]], 15 | [16 => [qw /deadbeaf c0c0a c1a0 55b/]], 16 | [10 => [qw /81320981536123490812346123 129 9/]], 17 | [ 8 => [qw /777 153/]], 18 | [ 2 => [qw /0 1 1010101110/]], 19 | ); 20 | 21 | my (%targets, @tests); 22 | 23 | foreach my $entry (@data) { 24 | my ($base, $list) = @$entry; 25 | 26 | $targets {"${base}_int"} = { 27 | list => $list, 28 | query => sub {$_ [0]}, 29 | wanted => sub {$_ [0], "", $_ [0], $_ [0], undef, undef} 30 | }; 31 | 32 | for my $exp ([dot => "."], [comma => ","]) { 33 | my ($name, $punct) = @$exp; 34 | $targets {"${base}_int_${name}"} = { 35 | list => $list, 36 | query => sub {$_ [0] . $punct}, 37 | wanted => sub {$_ [0] . $punct, "", 38 | $_ [0] . $punct, $_ [0], $punct, ""} 39 | }; 40 | 41 | $targets {"${base}_${name}_frac"} = { 42 | list => $list, 43 | query => sub {$_ [0] . $punct}, 44 | wanted => sub {$_ [0] . $punct, "", 45 | $_ [0] . $punct, $_ [0], $punct, ""} 46 | }; 47 | 48 | $targets {"${base}_minus_${name}_frac"} = { 49 | list => $list, 50 | query => sub {"-" . $_ [0] . $punct}, 51 | wanted => sub {"-" . $_ [0] . $punct, "-", 52 | $_ [0] . $punct, $_ [0], $punct, ""} 53 | }; 54 | 55 | $targets {"${base}_plus_${name}_frac"} = { 56 | list => $list, 57 | query => sub {"+" . $_ [0] . $punct}, 58 | wanted => sub {"+" . $_ [0] . $punct, "+", 59 | $_ [0] . $punct, $_ [0], $punct, ""} 60 | }; 61 | } 62 | 63 | $targets {"${base}_minus_int"} = { 64 | list => $list, 65 | query => sub {"-" . $_ [0]}, 66 | wanted => sub {"-" . $_ [0], "-", $_ [0], $_ [0], "", ""} 67 | }; 68 | 69 | $targets {"${base}_plus_int"} = { 70 | list => $list, 71 | query => sub {"+" . $_ [0]}, 72 | wanted => sub {"+" . $_ [0], "+", $_ [0], $_ [0], "", ""} 73 | }; 74 | } 75 | 76 | $targets {dot} = { 77 | list => ['.'], 78 | query => sub {$_ [0]}, 79 | }; 80 | 81 | sub __ { 82 | map {;"${_}_int", "${_}_int_dot", 83 | "${_}_minus_int", "${_}_plus_int", 84 | "${_}_dot_frac", "${_}_minus_dot_frac", "${_}_plus_dot_frac", 85 | } @_ 86 | } 87 | 88 | sub _2 { 89 | map {;"${_}_minus_int", "${_}_plus_int", 90 | "${_}_minus_dot_frac", "${_}_plus_dot_frac", 91 | } @_ 92 | } 93 | 94 | sub _3 { 95 | map {;"${_}_int", "${_}_int_dot", 96 | "${_}_dot_frac", 97 | } @_ 98 | } 99 | 100 | push @tests => { 101 | name => 'basic', 102 | re => $decimal, 103 | sub => \&RE_num_decimal, 104 | pass => [__ (grep {$_ <= 10} map {$$_ [0]} @data)], 105 | fail => [__ (grep {$_ > 10} map {$$_ [0]} @data), "dot"], 106 | }; 107 | 108 | 109 | push @tests => { 110 | name => 'basic -- signed', 111 | re => $decimal -> {-sign => '[-+]'}, 112 | sub => \&RE_num_decimal, 113 | sub_args => [-sign => '[-+]'], 114 | pass => [ _2 (grep {$_ <= 10} map {$$_ [0]} @data)], 115 | fail => [(_3 (grep {$_ <= 10} map {$$_ [0]} @data)), 116 | __ (grep {$_ > 10} map {$$_ [0]} @data), "dot"], 117 | }; 118 | 119 | foreach my $data (@data) { 120 | my $base = $$data [0]; 121 | my @passes = __ grep {$_ <= $base} map {$$_ [0]} @data; 122 | my @failures = __ grep {$_ > $base} map {$$_ [0]} @data; 123 | 124 | my @commas = grep {/^${base}_.*comma/} keys %targets; 125 | 126 | push @tests => { 127 | name => "base_${base}", 128 | re => $RE {num} {decimal} {-base => $base}, 129 | sub => \&RE_num_decimal, 130 | sub_args => [-base => $base], 131 | pass => [@passes], 132 | fail => [@failures, @commas, "dot"], 133 | }; 134 | push @tests => { 135 | name => "base_${base}_comma", 136 | re => $RE {num} {decimal} {-base => $base} {-radix => ","}, 137 | sub => \&RE_num_decimal, 138 | sub_args => [-base => $base, -radix => ","], 139 | pass => [(grep {!/dot/} @passes), @commas], 140 | fail => [(grep {/^${base}/} @failures)], 141 | }; 142 | } 143 | 144 | 145 | 146 | run_new_tests targets => \%targets, 147 | tests => \@tests, 148 | version_from => 'Regexp::Common::number', 149 | ; 150 | 151 | __END__ 152 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/RFC1808.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::RFC1808; 2 | 3 | BEGIN { 4 | # This makes sure 'use warnings' doesn't bomb out on 5.005_*; 5 | # warnings won't be enabled on those old versions though. 6 | if ($] < 5.006 && !exists $INC {"warnings.pm"}) { 7 | $INC {"warnings.pm"} = 1; 8 | no strict 'refs'; 9 | *{"warnings::unimport"} = sub {0}; 10 | } 11 | } 12 | 13 | use strict; 14 | use warnings; 15 | 16 | our $VERSION = '2024080801'; 17 | 18 | use Exporter (); 19 | our @ISA = qw /Exporter/; 20 | 21 | 22 | my %vars; 23 | 24 | BEGIN { 25 | $vars {low} = [qw /$punctuation $reserved_range $reserved $national 26 | $extra $safe $digit $digits $hialpha $lowalpha 27 | $alpha $alphadigit $hex $escape $unreserved_range 28 | $unreserved $uchar $uchars $pchar_range $pchar 29 | $pchars/], 30 | 31 | $vars {parts} = [qw /$fragment $query $param $params $segment 32 | $fsegment $path $net_loc $scheme $rel_path 33 | $abs_path $net_path $relativeURL $generic_RL 34 | $absoluteURL $URL/], 35 | } 36 | 37 | our @EXPORT = qw /$host/; 38 | our @EXPORT_OK = map {@$_} values %vars; 39 | our %EXPORT_TAGS = (%vars, ALL => [@EXPORT_OK]); 40 | 41 | # RFC 1808, base definitions. 42 | 43 | # Lowlevel definitions. 44 | our $punctuation = '[<>#%"]'; 45 | our $reserved_range = q [;/?:@&=]; 46 | our $reserved = "[$reserved_range]"; 47 | our $national = '[][{}|\\^~`]'; 48 | our $extra = "[!*'(),]"; 49 | our $safe = '[-$_.+]'; 50 | 51 | our $digit = '[0-9]'; 52 | our $digits = '[0-9]+'; 53 | our $hialpha = '[A-Z]'; 54 | our $lowalpha = '[a-z]'; 55 | our $alpha = '[a-zA-Z]'; # lowalpha | hialpha 56 | our $alphadigit = '[a-zA-Z0-9]'; # alpha | digit 57 | 58 | our $hex = '[a-fA-F0-9]'; 59 | our $escape = "(?:%$hex$hex)"; 60 | 61 | our $unreserved_range = q [-a-zA-Z0-9$_.+!*'(),]; # alphadigit | safe | extra 62 | our $unreserved = "[$unreserved_range]"; 63 | our $uchar = "(?:$unreserved|$escape)"; 64 | our $uchars = "(?:(?:$unreserved+|$escape)*)"; 65 | 66 | our $pchar_range = qq [$unreserved_range:\@&=]; 67 | our $pchar = "(?:[$pchar_range]|$escape)"; 68 | our $pchars = "(?:(?:[$pchar_range]+|$escape)*)"; 69 | 70 | 71 | # Parts 72 | our $fragment = "(?:(?:[$unreserved_range$reserved_range]+|" . 73 | "$escape)*)"; 74 | our $query = "(?:(?:[$unreserved_range$reserved_range]+|" . 75 | "$escape)*)"; 76 | 77 | our $param = "(?:(?:[$pchar_range/]+|$escape)*)"; 78 | our $params = "(?:$param(?:;$param)*)"; 79 | 80 | our $segment = "(?:(?:[$pchar_range]+|$escape)*)"; 81 | our $fsegment = "(?:(?:[$pchar_range]+|$escape)+)"; 82 | our $path = "(?:$fsegment(?:/$segment)*)"; 83 | 84 | our $net_loc = "(?:(?:[$pchar_range;?]+|$escape)*)"; 85 | our $scheme = "(?:(?:[-a-zA-Z0-9+.]+|$escape)+)"; 86 | 87 | our $rel_path = "(?:$path?(?:;$params)?(?:?$query)?)"; 88 | our $abs_path = "(?:/$rel_path)"; 89 | our $net_path = "(?://$net_loc$abs_path?)"; 90 | 91 | our $relativeURL = "(?:$net_path|$abs_path|$rel_path)"; 92 | our $generic_RL = "(?:$scheme:$relativeURL)"; 93 | our $absoluteURL = "(?:$generic_RL|" . 94 | "(?:$scheme:(?:[$unreserved_range$reserved_range]+|" . 95 | "$escape)*))"; 96 | our $URL = "(?:(?:$absoluteURL|$relativeURL)(?:#$fragment)?)"; 97 | 98 | 99 | 1; 100 | 101 | __END__ 102 | 103 | =pod 104 | 105 | =head1 NAME 106 | 107 | Regexp::Common::URI::RFC1808 -- Definitions from RFC1808; 108 | 109 | =head1 SYNOPSIS 110 | 111 | use Regexp::Common::URI::RFC1808 qw /:ALL/; 112 | 113 | =head1 DESCRIPTION 114 | 115 | This package exports definitions from RFC1808. It's intended 116 | usage is for Regexp::Common::URI submodules only. Its interface 117 | might change without notice. 118 | 119 | =head1 REFERENCES 120 | 121 | =over 4 122 | 123 | =item B<[RFC 1808]> 124 | 125 | Fielding, R.: I. June 1995. 126 | 127 | =back 128 | 129 | =head1 AUTHOR 130 | 131 | Damian Conway (damian@conway.org) 132 | 133 | =head1 MAINTENANCE 134 | 135 | This package is maintained by Abigail S<(I)>. 136 | 137 | =head1 BUGS AND IRRITATIONS 138 | 139 | Bound to be plenty. 140 | 141 | =head1 LICENSE and COPYRIGHT 142 | 143 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 144 | 145 | This module is free software, and maybe used under any of the following 146 | licenses: 147 | 148 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 149 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 150 | 3) The BSD License. See the file COPYRIGHT.BSD. 151 | 4) The MIT License. See the file COPYRIGHT.MIT. 152 | 153 | =cut 154 | -------------------------------------------------------------------------------- /lib/Regexp/Common/URI/gopher.pm: -------------------------------------------------------------------------------- 1 | package Regexp::Common::URI::gopher; 2 | 3 | use Regexp::Common qw /pattern clean no_defaults/; 4 | use Regexp::Common::URI qw /register_uri/; 5 | use Regexp::Common::URI::RFC1738 qw /$host $port $uchars/; 6 | use Regexp::Common::URI::RFC1808 qw /$pchars $pchar_range/; 7 | 8 | use strict; 9 | use warnings; 10 | 11 | our $VERSION = '2024080801'; 12 | 13 | 14 | my $pchars_notab = "(?:(?:[$pchar_range]+|" . 15 | "%(?:[1-9a-fA-F][0-9a-fA-F]|0[0-8a-fA-F]))*)"; 16 | 17 | my $gopherplus_string = $pchars; 18 | my $search = $pchars; 19 | my $search_notab = $pchars_notab; 20 | my $selector = $pchars; 21 | my $selector_notab = $pchars_notab; 22 | my $gopher_type = "(?:[0-9+IgT])"; 23 | 24 | my $scheme = "gopher"; 25 | my $uri = "(?k:(?k:$scheme)://(?k:$host)(?::(?k:$port))?" . 26 | "/(?k:(?k:$gopher_type)(?k:$selector)))"; 27 | my $uri_notab = "(?k:(?k:$scheme)://(?k:$host)(?::(?k:$port))?" . 28 | "/(?k:(?k:$gopher_type)(?k:$selector_notab)" . 29 | "(?:%09(?k:$search_notab)(?:%09(?k:$gopherplus_string))?)?))"; 30 | 31 | register_uri $scheme => $uri; 32 | 33 | pattern name => [qw (URI gopher -notab=)], 34 | create => sub { exists $_ [1] {-notab} && 35 | !defined $_ [1] {-notab} ? $uri_notab : $uri}, 36 | ; 37 | 38 | 1; 39 | 40 | __END__ 41 | 42 | =pod 43 | 44 | =head1 NAME 45 | 46 | Regexp::Common::URI::gopher -- Returns a pattern for gopher URIs. 47 | 48 | =head1 SYNOPSIS 49 | 50 | use Regexp::Common qw /URI/; 51 | 52 | while (<>) { 53 | /$RE{URI}{gopher}/ and print "Contains a gopher URI.\n"; 54 | } 55 | 56 | =head1 DESCRIPTION 57 | 58 | =head2 $RE{URI}{gopher}{-notab} 59 | 60 | Gopher URIs are poorly defined. Originally, RFC 1738 defined gopher URIs, 61 | but they were later redefined in an internet draft. One that was expired 62 | in June 1997. 63 | 64 | The internet draft for gopher URIs defines them as follows: 65 | 66 | "gopher:" "//" host [ ":" port ] "/" gopher-type selector 67 | [ "%09" search [ "%09" gopherplus_string ]] 68 | 69 | Unfortunally, a I is defined in such a way that characters 70 | may be escaped using the URI escape mechanism. This includes tabs, 71 | which escaped are C<%09>. Hence, the syntax cannot distinguish between 72 | a URI that has both a I and a I part, and an URI 73 | where the I includes an escaped tab. (The text of the draft 74 | forbids tabs to be present in the I though). 75 | 76 | C<$RE{URI}{gopher}> follows the defined syntax. To disallow escaped 77 | tabs in the I and I parts, use C<$RE{URI}{gopher}{-notab}>. 78 | 79 | There are other differences between the text and the given syntax. 80 | According to the text, selector strings cannot have tabs, linefeeds 81 | or carriage returns in them. The text also allows the entire I, 82 | (the part after the slash following the hostport) to be empty; if this 83 | is empty the slash may be omitted as well. However, this isn't reflected 84 | in the syntax. 85 | 86 | Under C<{-keep}>, the following are returned: 87 | 88 | =over 4 89 | 90 | =item $1 91 | 92 | The entire URI. 93 | 94 | =item $2 95 | 96 | The scheme. 97 | 98 | =item $3 99 | 100 | The host (name or address). 101 | 102 | =item $4 103 | 104 | The port (if any). 105 | 106 | =item $5 107 | 108 | The "gopher-path", the part after the / following the host and port. 109 | 110 | =item $6 111 | 112 | The gopher-type. 113 | 114 | =item $7 115 | 116 | The selector. (When no C<{-notab}> is used, this includes the search 117 | and gopherplus_string, including the separating escaped tabs). 118 | 119 | =item $8 120 | 121 | The search, if given. (Only when C<{-notab}> is given). 122 | 123 | =item $9 124 | 125 | The gopherplus_string, if given. (Only when C<{-notab}> is given). 126 | 127 | =back 128 | 129 | head1 REFERENCES 130 | 131 | =over 4 132 | 133 | =item B<[RFC 1738]> 134 | 135 | Berners-Lee, Tim, Masinter, L., McCahill, M.: I. December 1994. 137 | 138 | =item B<[RFC 1808]> 139 | 140 | Fielding, R.: I. June 1995. 141 | 142 | =item B<[GOPHER URL]> 143 | 144 | Krishnan, Murali R., Casey, James: "A Gopher URL Format". Expired 145 | Internet draft I. December 1996. 146 | 147 | =back 148 | 149 | =head1 SEE ALSO 150 | 151 | L for other supported URIs. 152 | 153 | =head1 AUTHOR 154 | 155 | Damian Conway (damian@conway.org) 156 | 157 | =head1 MAINTENANCE 158 | 159 | This package is maintained by Abigail S<(I)>. 160 | 161 | =head1 BUGS AND IRRITATIONS 162 | 163 | Bound to be plenty. 164 | 165 | =head1 LICENSE and COPYRIGHT 166 | 167 | This software is Copyright (c) 2001 - 2024, Damian Conway and Abigail. 168 | 169 | This module is free software, and maybe used under any of the following 170 | licenses: 171 | 172 | 1) The Perl Artistic License. See the file COPYRIGHT.AL. 173 | 2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2. 174 | 3) The BSD License. See the file COPYRIGHT.BSD. 175 | 4) The MIT License. See the file COPYRIGHT.MIT. 176 | 177 | =cut 178 | -------------------------------------------------------------------------------- /COPYRIGHT.AL: -------------------------------------------------------------------------------- 1 | The Artistic License 2 | 3 | Preamble 4 | 5 | The intent of this document is to state the conditions under which a 6 | Package may be copied, such that the Copyright Holder maintains some 7 | semblance of artistic control over the development of the package, while 8 | giving the users of the package the right to use and distribute the 9 | Package in a more-or-less customary fashion, plus the right to make 10 | reasonable modifications. 11 | 12 | Definitions: 13 | 14 | * "Package" refers to the collection of files distributed by the 15 | Copyright Holder, and derivatives of that collection of files 16 | created through textual modification. 17 | * "Standard Version" refers to such a Package if it has not been 18 | modified, or has been modified in accordance with the wishes of 19 | the Copyright Holder. 20 | * "Copyright Holder" is whoever is named in the copyright or 21 | copyrights for the package. 22 | * "You" is you, if you're thinking about copying or distributing 23 | this Package. 24 | * "Reasonable copying fee" is whatever you can justify on the basis 25 | of media cost, duplication charges, time of people involved, and 26 | so on. (You will not be required to justify it to the Copyright 27 | Holder, but only to the computing community at large as a market 28 | that must bear the fee.) 29 | * "Freely Available" means that no fee is charged for the item 30 | itself, though there may be fees involved in handling the item. It 31 | also means that recipients of the item may redistribute it under 32 | the same conditions they received it. 33 | 34 | 1. You may make and give away verbatim copies of the source form of the 35 | Standard Version of this Package without restriction, provided that you 36 | duplicate all of the original copyright notices and associated disclaimers. 37 | 38 | 2. You may apply bug fixes, portability fixes and other modifications 39 | derived from the Public Domain or from the Copyright Holder. A Package 40 | modified in such a way shall still be considered the Standard Version. 41 | 42 | 3. You may otherwise modify your copy of this Package in any way, 43 | provided that you insert a prominent notice in each changed file stating 44 | how and when you changed that file, and provided that you do at least 45 | ONE of the following: 46 | 47 | a) place your modifications in the Public Domain or otherwise make 48 | them Freely Available, such as by posting said modifications to 49 | Usenet or an equivalent medium, or placing the modifications on a 50 | major archive site such as ftp.uu.net, or by allowing the Copyright 51 | Holder to include your modifications in the Standard Version of the 52 | Package. 53 | 54 | b) use the modified Package only within your corporation or 55 | organization. 56 | 57 | c) rename any non-standard executables so the names do not conflict 58 | with standard executables, which must also be provided, and provide 59 | a separate manual page for each non-standard executable that clearly 60 | documents how it differs from the Standard Version. 61 | 62 | d) make other distribution arrangements with the Copyright Holder. 63 | 64 | 4. You may distribute the programs of this Package in object code or 65 | executable form, provided that you do at least ONE of the following: 66 | 67 | a) distribute a Standard Version of the executables and library 68 | files, together with instructions (in the manual page or equivalent) 69 | on where to get the Standard Version. 70 | 71 | b) accompany the distribution with the machine-readable source of 72 | the Package with your modifications. 73 | 74 | c) accompany any non-standard executables with their corresponding 75 | Standard Version executables, giving the non-standard executables 76 | non-standard names, and clearly documenting the differences in 77 | manual pages (or equivalent), together with instructions on where to 78 | get the Standard Version. 79 | 80 | d) make other distribution arrangements with the Copyright Holder. 81 | 82 | 5. You may charge a reasonable copying fee for any distribution of this 83 | Package. You may charge any fee you choose for support of this Package. 84 | You may not charge a fee for this Package itself. However, you may 85 | distribute this Package in aggregate with other (possibly commercial) 86 | programs as part of a larger (possibly commercial) software distribution 87 | provided that you do not advertise this Package as a product of your own. 88 | 89 | 6. The scripts and library files supplied as input to or produced as 90 | output from the programs of this Package do not automatically fall under 91 | the copyright of this Package, but belong to whomever generated them, 92 | and may be sold commercially, and may be aggregated with this Package. 93 | 94 | 7. C or perl subroutines supplied by you and linked into this Package 95 | shall not be considered part of this Package. 96 | 97 | 8. The name of the Copyright Holder may not be used to endorse or 98 | promote products derived from this software without specific prior 99 | written permission. 100 | 101 | 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 102 | WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 103 | MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 104 | 105 | The End 106 | --------------------------------------------------------------------------------