Test-Regexp-2017040101/000700 000765 000024 00000000000 13067715147 015016 5ustar00abigailstaff000000 000000 Test-Regexp-2017040101/Changes000644 000765 000024 00000004577 13067713662 016340 0ustar00abigailstaff000000 000000 Version 2017040101 Sat Apr 1 14:05:59 CEST 2017 + Prepare for 5.26 Version 2016060501 Sun Jun 5 00:40:52 CEST 2016 + Fix POD spelling errors (Salvatore Bonaccorso ) Version 2016052701 Fri May 27 19:46:42 CEST 2016 + Allow specifying how you want display characters which aren't printable ASCII characters. It used to be displayed as hex escapes. We know also allow named escapes, "as is", \n/\r/\t only or "only escape non-printable ASCII", which is the new default. Version 2015110201 Mon Nov 2 21:34:52 CET 2015 + Removed a my() inside a my(). This is a new failure in 5.23.* + Eliminate the use of given Version 2014052301 Fri May 23 20:49:03 CEST 2014 + Allow surprising the "(with -Keep)" using the "no_keep_message" option. Version 2013042301 Tue Apr 23 16:07:05 CEST 2013 + Fall back to using the pattern if neither name or comment are given. Version 2013042101 Sun Apr 21 23:34:57 CEST 2013 + Made a 'name' accessor for Test::Regexp::Object + Allow objects to store "tags". + Remove ghost_num_captures and ghost_name_captures. Version 2013041501 Mon Apr 15 23:45:33 CEST 2013 + Add Test::Tester to test_requires + Added a "todo" parameter to match() Version 2013041201 Fri Apr 12 23:05:10 CEST 2013 + Made the 'full_text' option to work. Version 2013040301 Wed Apr 3 14:19:40 CEST 2013 + Sync version numbers between files. Version 2013040201 Tue Apr 2 19:33:03 CEST 2013 + Used Test::Tester to check tests. Version 2009121701 + Removed t/990_kwalitee.t Version 2009121403 + Sync VERSION numbers Version 2009121402 + Require Test::More 0.88. Version 2009121401 + Tweaks in displaying messages. Version 2009121001 + Better skipping of tests. Version 2009120903 + Use @+ instead of @- to find the number of captures. Version 2009120902 + Tweaked undocumented features. Version 2009120901 + Added undocumented features. Version 2009120801 + Added 'test' option to 'match'. Version 2009120501 + Methods 'match' and 'no_match' can take additional parameters. Version 2009120301 + Fixed a bug that autovivified the correct number of named params. + Set build_requires & configure_requires. Version 2009041401 + Added tests for POD and Kwalitee Version 2009041401 + Fixed MANIFEST. Version 2009041001 + Add OO interface. Version 2009040901 + Modernized Makefile.PL. + POD fixes. + Added Changes file. + Removed $VERSION from test files. Version 2009033101 + Initial release Test-Regexp-2017040101/lib/000700 000765 000024 00000000000 13067715146 015563 5ustar00abigailstaff000000 000000 Test-Regexp-2017040101/Makefile.PL000644 000765 000024 00000003260 12132126527 016771 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use 5.010; use strict; use warnings; no warnings 'syntax'; use ExtUtils::MakeMaker; my %args = ( NAME => 'Test::Regexp', VERSION_FROM => 'lib/Test/Regexp.pm', ABSTRACT_FROM => 'lib/Test/Regexp.pm', PREREQ_PM => { 'Exporter' => 0, 'Hash::Util::FieldHash' => 0, 'Test::Builder' => 0, 'warnings' => 0, 'strict' => 0, }, MIN_PERL_VERSION => 5.010, AUTHOR => 'Abigail ', LICENSE => 'mit', META_MERGE => { test_requires => { 'Test::More' => 0.88, 'Test::Tester' => 0, 'warnings' => 0, 'strict' => 0, }, resources => { repository => 'git://github.com/Abigail/Test-Regexp.git', }, keywords => ['regular expression', 'pattern', 'regexp', 'test', 'tests'], }, ); $args {META_MERGE} {build_requires} ||= { 'ExtUtils::MakeMaker' => 0, %{$args {META_MERGE} {test_requires}} }; $args {META_MERGE} {configure_requires} ||= $args {META_MERGE} {build_requires}; my %filter = ( MIN_PERL_VERSION => '6.48', META_MERGE => '6.46', AUTHOR => '6.07', ABSTRACT_FROM => '6.07', LICENSE => '6.07', ); delete $args {$_} for grep {defined $filter {$_} && $ExtUtils::MakeMaker::VERSION lt $filter {$_}} keys %args; WriteMakefile %args; __END__ Test-Regexp-2017040101/MANIFEST000644 000765 000024 00000001147 13067715147 016164 0ustar00abigailstaff000000 000000 Makefile.PL Changes MANIFEST README TODO lib/Test/Regexp.pm t/100_use.t t/101_import.t t/102_import.t t/110_pattern.t t/120_keep_pattern.t t/130_comment.t t/140_utf8.t t/150_reason.t t/160_show_line.t t/170_todo.t t/180_full_text.t t/200_use.t t/201_example.t t/210_object.t t/211_objects.t t/212_object_extra_args.t t/220_object_comment.t t/230_tags.t t/950_pod.t t/960_pod_coverage.t t/980_versions.t t/981_permissions.t t/982_git.t t/Common.pm META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Test-Regexp-2017040101/META.json000600 000765 000024 00000003164 13067715147 016445 0ustar00abigailstaff000000 000000 { "abstract" : "Test your regular expressions", "author" : [ "Abigail " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001", "keywords" : [ "regular expression", "pattern", "regexp", "test", "tests" ], "license" : [ "mit" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Regexp", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0", "Test::More" : "0.88", "Test::Tester" : "0", "strict" : "0", "warnings" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0", "Test::More" : "0.88", "Test::Tester" : "0", "strict" : "0", "warnings" : "0" } }, "runtime" : { "requires" : { "Exporter" : "0", "Hash::Util::FieldHash" : "0", "Test::Builder" : "0", "perl" : "5.01", "strict" : "0", "warnings" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "git://github.com/Abigail/Test-Regexp.git" } }, "version" : "2017040101", "x_test_requires" : { "Test::More" : 0.88, "Test::Tester" : 0, "strict" : 0, "warnings" : 0 } } Test-Regexp-2017040101/META.yml000600 000765 000024 00000001703 13067715146 016271 0ustar00abigailstaff000000 000000 --- abstract: 'Test your regular expressions' author: - 'Abigail ' build_requires: ExtUtils::MakeMaker: '0' Test::More: '0.88' Test::Tester: '0' strict: '0' warnings: '0' configure_requires: ExtUtils::MakeMaker: '0' Test::More: '0.88' Test::Tester: '0' strict: '0' warnings: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001' keywords: - 'regular expression' - pattern - regexp - test - tests license: mit meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-Regexp no_index: directory: - t - inc requires: Exporter: '0' Hash::Util::FieldHash: '0' Test::Builder: '0' perl: '5.01' strict: '0' warnings: '0' resources: repository: git://github.com/Abigail/Test-Regexp.git version: '2017040101' x_test_requires: Test::More: 0.88 Test::Tester: 0 strict: 0 warnings: 0 Test-Regexp-2017040101/README000644 000765 000024 00000000631 13067713730 015704 0ustar00abigailstaff000000 000000 This is version 2017040101 of Test::Regexp, a module to test regular expressions with. It's a pure perl module, and should install anywhere using perl Makefile.PL make make test make install The module requires Perl 5.10 or later. It will not work on 5.8.x or before, and there are no plans to backport it. Development versions can be retrieved from github. Abigail, test-regexp@abigail.be Test-Regexp-2017040101/t/000700 000765 000024 00000000000 13067715146 015260 5ustar00abigailstaff000000 000000 Test-Regexp-2017040101/TODO000644 000765 000024 00000000150 12135513141 015475 0ustar00abigailstaff000000 000000 ============= - Test undefined numbered matches from unmatched part of (?|...|...) - Use nested tests. Test-Regexp-2017040101/t/100_use.t000755 000765 000024 00000000241 12120705101 016606 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; BEGIN { use_ok 'Test::Regexp'; } ok defined &match; ok defined &no_match; __END__ Test-Regexp-2017040101/t/101_import.t000755 000765 000024 00000000276 12120705101 017335 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; BEGIN { use_ok 'Test::Regexp', import => [qw [no_match]]; } ok !defined &match; ok defined &no_match; __END__ Test-Regexp-2017040101/t/102_import.t000755 000765 000024 00000000261 12120705101 017330 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; BEGIN { use_ok 'Test::Regexp', import => []; } ok !defined &match; ok !defined &no_match; __END__ Test-Regexp-2017040101/t/110_pattern.t000755 000765 000024 00000003030 13067713221 017504 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp; use t::Common; while () { chomp; m {^\h* (?|"(?[^"]*)"|(?\S+)) \h+ (?|/(?[^/]*)/|(?\S+)) \h+ (?(?i:[ymn01])) \h+ (?[PFS]+) \h* (?:$|\#)}x or next; my ($subject, $pattern, $match, $expected) = @+ {qw [subject pattern match result]}; my $match_val = $match =~ /[ym1]/i; my $match_res; my ($premature, @results) = run_tests sub { $match_res = match subject => $subject, pattern => $pattern, match => $match_val; }; check results => \@results, premature => $premature, expected => $expected, match => $match_val, match_res => $match_res, pattern => $pattern, subject => $subject, ; } # # Names in the __DATA__ section come from 'meta norse_mythology'. # __DATA__ Dagr .... y PPPP Kvasir Kvasir y PPPP Snotra \w+ y PPPP Sjofn \w+ n F # It matches, so a no_match should fail Borr Bo y PFSS # Match is only partial Magni Sigyn y FSSS # Fail, then a skip Andhrimnir Delling n P # Doesn't match, so a pass Hlin .(.).. y PPFP # Sets a capture, so should fail Od (?.*) y PPFF # Sets a capture, so should fail Test-Regexp-2017040101/t/120_keep_pattern.t000755 000765 000024 00000010275 13067713221 020522 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp; use t::Common; sub init_data; my @data = init_data; my $seen; foreach my $data (@data) { my ($subject, $pattern, $match, $expected, $captures) = @$data; my $match_val = $match =~ /[ym1]/i; my $match_res; my ($premature, @results) = run_tests sub { $match_res = match subject => $subject, keep_pattern => $pattern, match => $match_val, captures => $captures, }; check results => \@results, premature => $premature, expected => $expected, match => $match_val, match_res => $match_res, pattern => $pattern, subject => $subject, keep => 1, ; if ($match_res && ! $seen ++) { my ($premature, @results) = run_tests sub { $match_res = match subject => $subject, keep_pattern => $pattern, no_keep_message => 1, match => $match_val, captures => $captures, }; check results => \@results, premature => $premature, expected => $expected, match => $match_val, match_res => $match_res, pattern => $pattern, subject => $subject, ; } } # # Data taken from 'meta state_flowers' # sub init_data {( # Match without captures. ['Rose', qr {\w+}, 'y', 'PPPP', []], # Match with just numbered captures. ['Black Eyed Susan', qr {(\w+)\s+(\w+)\s+(\w+)}, 'y', 'PPPPPPP', [qw [Black Eyed Susan]]], # Match with just named captures. ['Sego Lily', qr {(?\w+)\s+(?\w+)}, 'y', 'PPPPPPPPPP', [[a => 'Sego'], [b => 'Lily']]], # Mix named and numbered captures. ['California Poppy', qr {(?\w+)\s+(\w+)}, 'y', 'PPPPPPPP', [[state => 'California'], 'Poppy']], # Repeat named capture. ['Indian Paintbrush', qr {(?\w+)\s+(?\w+)}, 'y', 'PPPPPPPPP', [[s => 'Indian'], [s => 'Paintbrush']]], # # Failures. # # No captures, but a result. ['Violet', qr {\w+}, 'y', 'PPPFF', ['Violet']], # Capture, no result. ['Mayflower', qr {(\w+)}, 'y', 'PPPF', []], # Capture, wrong result. ['Magnolia', qr {(\w+)}, 'y', 'PPPFP', ['Violet']], # Named capture, numbered results. ['Hawaiian Hibiscus', qr {(?\w+)\s+(?\w+)}, 'y', 'PPFPPP', [qw [Hawaiian Hibiscus]]], # Numbered capture, named results. ['Cherokee Rose', qr {(\w+)\s+(\w+)}, 'y', 'PPFFFFFPPP', [[a => 'Cherokee'], [b => 'Rose']]], # Wrong capture names. ['American Dogwood', qr {(?\w+)\s+(?\w+)}, 'y', 'PPFPFPPPPP', [[b => 'American'], [a => 'Dogwood']]], # Wrong order of captures. ['Mountain Laurel', qr {(?\w+)\s+(?\w+)}, 'y', 'PPPPPPPFFP', [[b => 'Laurel'], [a => 'Mountain']]], # Wrong order of captures - same name ['Yucca Flower', qr {(?\w+)\s+(?\w+)}, 'y', 'PPFFPPFFP', [[a => 'Flower'], [a => 'Yucca']]], # Too many numbered captures. ['Sagebrush', qr {(\w+)}, 'y', 'PPPPFF', [qw [Sagebrush Violet]]], # Too many named captures. ['Apple Blossom', qr {(?\w+)\s+(?\w+)}, 'y', 'PPPPFFPPPFF', [[a => 'Apple'], [a => 'Blossom'], [a => 'Violet']]], # Not enough named captures. ['Wood Violet', qr {(?\w+)\s+(?\w+)}, 'y', 'PPPFPPF', [[a => 'Wood']]], # Incomplete match ['Forget Me Not', qr {(?\w+)\s+(?\w+)}, 'y', 'PFSSSSSSSS', [[a => 'Forget'], [b => 'Me']]], # Incomplete match ['Forget Me Not 2', qr {(?\w+)\s+(?\w+)\s+(?\w+)}, 'y', 'PFSSSSSSSSSSS', [[a => 'Forget'], [b => 'Me'], [c => 'Not']]], )} __END__ Test-Regexp-2017040101/t/130_comment.t000755 000765 000024 00000001742 13067713221 017503 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp; use t::Common; my $match_res; foreach my $name (undef, "", "Hello", "Flip Flap") { foreach my $arg_name ("name", "comment") { foreach my $keep (0, 1) { my $p_arg_name = $keep ? "keep_pattern" : "pattern"; my ($premature, @results) = run_tests sub { $match_res = match subject => "Foo", $p_arg_name => qr {Foo}, $arg_name => $name, }; check results => \@results, premature => $premature, expected => 'PPPP', match => 1, match_res => $match_res, pattern => 'Foo', subject => "Foo", comment => $name, keep => $keep, ; } } } Test-Regexp-2017040101/t/140_utf8.t000755 000765 000024 00000005126 13067713221 016730 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; BEGIN { binmode STDOUT, ":utf8" or die; binmode STDERR, ":utf8" or die; } use Test::Tester; use Test::Regexp; use t::Common; sub init_data; my @data = init_data; my $match_res; foreach my $data (@data) { my ($subject, $pattern, $match, $expected_l, $captures) = @$data; for my $updown (qw [up down]) { my $subject2 = $subject; if ($updown eq "up") { utf8::upgrade ($subject2); } else { utf8::downgrade ($subject2); } my $keep = @$captures; my $param = $keep ? "keep_pattern" : "pattern"; foreach my $args ([], [utf8_upgrade => 0], [utf8_downgrade => 0]) { my $match_val = $match =~ /[ym1]/i; my $expected = shift @$expected_l; # # For now, we aren't testing without any escaping -- this # requires some special handling of newlines to not upset # run_test. # foreach my $escape (1 .. 4) { my ($premature, @results) = run_tests sub { $match_res = match subject => $subject2, $param => $pattern, match => $match_val, captures => $captures, escape => $escape, @$args, }; check results => \@results, premature => $premature, expected => $expected, match => $match_val, match_res => $match_res, pattern => $pattern, subject => $subject2, keep => $keep, escape => $escape, ; } } } } sub init_data {( # Match without captures. ["F\x{f8}o", qr /[\x20-\xFF]+/, 'y', ['PPPPPPPP', 'PPPPPPPP', 'PPPP', 'PPPPPPPP', 'PPPP', 'PPPPPPPP'], []], # Match without captures. ["F\x{f8}o", qr /\w+/, 'y', ['PPPPPFSS', 'PPPPPFSS', 'PPPP', 'PFSSPPPP', 'PFSS', 'PFSSPPPP'], []], # Match with captures ["F\x{f8}o", qr /[\x20-\xFF](?[\x20-\xFF])(?[\x20-\xFF])/, 'y', ['PPPPPPPPPPPPPPPPPPPP', 'PPPPPPPPPPPPPPPPPPPP', 'PPPPPPPPPP', 'PPPPPPPPPPPPPPPPPPPP', 'PPPPPPPPPP', 'PPPPPPPPPPPPPPPPPPPP'], [[a => "\x{f8}"], [b => "o"]]], )} __END__ Test-Regexp-2017040101/t/150_reason.t000755 000765 000024 00000002333 13067713221 017327 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp; use t::Common; my $match_res; foreach my $reason (undef, "", 0, "Bla bla bla") { foreach my $name ("", "Baz", "Qux Quux") { foreach my $match (0, 1) { my $pattern = $match ? qr {Foo} : qr {Bar}; my ($premature, @results) = run_tests sub { $match_res = match subject => "Foo", pattern => $pattern, match => $match, reason => $reason, test => $reason, name => $name, }; check results => \@results, premature => $premature, expected => $match ? 'PPPP' : 'P', match => $match, match_res => $match_res, pattern => $pattern, subject => "Foo", comment => $name, keep => 0, $match ? (test => $reason) : (reason => $reason), ; } } } __END__ Test-Regexp-2017040101/t/160_show_line.t000755 000765 000024 00000002553 13067713221 020034 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp; use t::Common; my $match_res; foreach my $reason (undef, "", 0, "Bla bla bla") { foreach my $name ("", "Baz", "Qux Quux") { foreach my $match (0, 1) { my $pattern = $match ? qr {Foo} : qr {Bar}; my ($premature, @results) = run_tests sub { #line 999 160_show_line $match_res = match subject => "Foo", pattern => $pattern, match => $match, reason => $reason, test => $reason, name => $name, show_line => 1, }; check results => \@results, premature => $premature, expected => $match ? 'PPPP' : 'P', match => $match, match_res => $match_res, pattern => $pattern, subject => "Foo", comment => $name, keep => 0, line => [999 => '160_show_line'], $match ? (test => $reason) : (reason => $reason), ; } } } __END__ Test-Regexp-2017040101/t/170_todo.t000755 000765 000024 00000001515 13067713221 017010 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp; use t::Common; my $match_res; foreach my $pattern (qr {Foo}, qr {Bar}) { foreach my $match (0, 1) { my ($premature, @results) = run_tests sub { $match_res = match subject => "Foo", pattern => $pattern, match => $match, todo => "Todo test", }; check results => \@results, premature => $premature, expected => $match ? 'PPPP' : 'P', match => $match, match_res => $match_res, pattern => $pattern, subject => "Foo", todo => "Todo test", ; } } __END__ Test-Regexp-2017040101/t/180_full_text.t000755 000765 000024 00000001337 12135513141 020046 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use Test::Tester; use Test::Regexp; use Test::More 0.88; my $subject = "0123456789" x 10; my $trunc_subject = "0123456789" x 5; $trunc_subject .= "...56789"; my $pat = qr /.+/; foreach my $full_text (0, 1) { my ($premature, @results) = run_tests sub { match subject => "$subject", pattern => $pat, full_text => $full_text, ; }; my $exp_subject = $full_text ? $subject : $trunc_subject; my $not = $full_text ? "not " : ""; is $results [0] {name}, qq {qq {$exp_subject} matched by /$pat/}, "Subject is ${not}truncated"; } done_testing; Test-Regexp-2017040101/t/200_use.t000755 000765 000024 00000001262 12120705101 016613 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; BEGIN { use_ok 'Test::Regexp'; } my $obj1 = Test::Regexp -> new; my $obj2 = Test::Regexp -> new -> init; my $obj3 = Test::Regexp::Object -> new; my $obj4 = Test::Regexp::Object -> new -> init; isa_ok $obj1, 'Test::Regexp::Object'; isa_ok $obj2, 'Test::Regexp::Object'; isa_ok $obj3, 'Test::Regexp::Object'; isa_ok $obj4, 'Test::Regexp::Object'; ok $obj1 != $obj2, "Different objects"; ok $obj1 != $obj3, "Different objects"; ok $obj1 != $obj4, "Different objects"; ok $obj2 != $obj3, "Different objects"; ok $obj2 != $obj4, "Different objects"; ok $obj3 != $obj4, "Different objects"; __END__ Test-Regexp-2017040101/t/201_example.t000755 000765 000024 00000000455 12120705101 017456 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::Regexp tests => 'no_plan'; my $checker = Test::Regexp -> new -> init ( keep_pattern => qr /(\w+)\s+\g{-1}/, name => "Double word matcher", ); $checker -> match ("foo foo", ["foo"]); $checker -> no_match ("foo bar"); __END__ Test-Regexp-2017040101/t/210_object.t000755 000765 000024 00000003371 13067713221 017306 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp import => []; use t::Common; while () { state $c = 0; $c ++; chomp; m {^\h* (?|"(?[^"]*)"|(?\S+)) \h+ (?|/(?[^/]*)/|(?\S+)) \h+ (?(?i:[ymn01])) \h+ (?[PFS]+) \h* (?:$|\#)}x or next; my ($subject, $pattern, $match, $expected) = @+ {qw [subject pattern match result]}; my $match_val = $match =~ /[ym1]/i; my $checker = Test::Regexp:: -> new -> init ( pattern => $pattern, name => "Name: $c", ); Test::More::is $checker -> name, "Name: $c", "Object has a name"; my $match_res; my $method = $match_val ? "match" : "no_match"; my ($premature, @results) = run_tests sub { $match_res = $checker -> $method ($subject) }; check results => \@results, premature => $premature, expected => $expected, match => $match_val, match_res => $match_res, pattern => $pattern, subject => $subject, comment => "Name: $c", ; } # # Names in the __DATA__ section come from 'meta norse_mythology'. # __DATA__ Dagr .... y PPPP Kvasir Kvasir y PPPP Snotra \w+ y PPPP Sjofn \w+ n F # It matches, so a no_match should fail Borr Bo y PFSS # Match is only partial Magni Sigyn y FSSS # Fail, then a skip Andhrimnir Delling n P # Doesn't match, so a pass Hlin .(.).. y PPFP # Sets a capture, so should fail Od (?.*) y PPFF # Sets a capture, so should fail Test-Regexp-2017040101/t/211_objects.t000755 000765 000024 00000003274 13067713221 017474 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp import => []; use t::Common; my $pattern2 = '(\w+)\s+(\w+)'; my $pattern3 = '(\w+)\s+(\w+)\s+(\w+)'; my $checker2 = Test::Regexp -> new -> init ( keep_pattern => $pattern2, ); my $checker3 = Test::Regexp -> new -> init ( keep_pattern => $pattern3, ); my @data = ( ['PFSSSSS', 'PPPPPPP', [qw [tripoline a punta]]], ['PPPPPP', 'FSSSSS', [qw [cannarozzi rigati]]], ['PPPPPP', 'FSSSSS', [qw [lumache grandi]]], ['PFSSSSSS', 'PFSSSSSS', [qw [lasagne festonate a nidi]]], ['PFSSSSS', 'PPPPPPP', [qw [corni di bue]]], ); foreach my $data (@data) { my $expected2 = shift @$data; my $expected3 = shift @$data; my $captures = shift @$data; my $subject = join ' ' => @$captures; my $match_res; my ($premature, @results) = run_tests sub { $match_res = $checker2 -> match ($subject, $captures) }; check results => \@results, premature => $premature, expected => $expected2, match => 1, match_res => $match_res, pattern => $pattern2, subject => $subject, captures => $captures, keep => 1, ; ($premature, @results) = run_tests sub { $match_res = $checker3 -> match ($subject, $captures) }; check results => \@results, premature => $premature, expected => $expected3, match => 1, match_res => $match_res, pattern => $pattern3, subject => $subject, captures => $captures, keep => 1, ; } __END__ Test-Regexp-2017040101/t/212_object_extra_args.t000755 000765 000024 00000001650 13067713221 021525 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp import => []; use t::Common; my $pattern = '\w+'; my $checker = Test::Regexp:: -> new -> init ( pattern => $pattern, name => "test", ); my @fails = (["----" => "dashes",], ["# foo" => "comment"], ["foo\nbar" => "has a newline"]); my $c = 0; foreach my $fail (@fails) { my ($subject, $Reason) = @$fail; my $match_res; my ($premature, @results) = run_tests sub { $match_res = $checker -> no_match ($subject, reason => $Reason); }; check results => \@results, premature => $premature, expected => 'P', match => 0, match_res => $match_res, pattern => $pattern, subject => $subject, reason => $Reason, comment => "test", ; } __END__ Test-Regexp-2017040101/t/220_object_comment.t000755 000765 000024 00000002375 13067713221 021034 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use lib "."; use Test::Tester; use Test::Regexp import => []; use t::Common; my $pattern = '(\w+)\s+(\w+)'; my @checkers = ( Test::Regexp:: -> new -> init ( keep_pattern => $pattern, pattern => '\w+\s+\w+', name => 'US president', ), Test::Regexp:: -> new -> init ( keep_pattern => $pattern, pattern => '\w+\s+\w+', comment => 'US president', ), ); my @data = ( ['PPPPPPPPPP', [qw [Gerald Ford]]], ['PPPPPPPPPP', [qw [Jimmy Carter]]], ); foreach my $data (@data) { my $expected = shift @$data; my $captures = shift @$data; my $subject = join ' ' => @$captures; foreach my $checker (@checkers) { my $match_res; my ($premature, @results) = run_tests sub { $match_res = $checker -> match ($subject, $captures); }; check results => \@results, premature => $premature, expected => $expected, match => 1, match_res => $match_res, pattern => $pattern, subject => $subject, comment => 'US president' ; } } __END__ Test-Regexp-2017040101/t/230_tags.t000755 000765 000024 00000001725 12134743350 017001 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use strict; use warnings; no warnings 'syntax'; use 5.010; use Test::More 0.88; use Test::Regexp import => []; # # Check to see whether the objects remember 'tags' # my $obj1 = Test::Regexp:: -> new -> init ( pattern => 'foo', tags => { -foo => 1, -bar => 2, } ); my $obj2 = Test::Regexp:: -> new -> init ( pattern => 'foo', tags => { -bar => 1, -baz => 3, -baz => 4, -qux => 5, } ); is $obj1 -> tag ('-foo'), 1, "Tag"; is $obj1 -> tag ('-bar'), 2, "Tag"; is $obj2 -> tag ('-bar'), 1, "Tag"; is $obj2 -> tag ('-baz'), 4, "Tag"; is $obj2 -> tag ('-qux'), 5, "Tag"; $obj2 -> set_tag (-quux => 6); $obj2 -> set_tag (-bar => 7); is $obj1 -> tag ('-foo'), 1, "Tag"; is $obj1 -> tag ('-bar'), 2, "Tag"; is $obj2 -> tag ('-bar'), 7, "Tag"; is $obj2 -> tag ('-baz'), 4, "Tag"; is $obj2 -> tag ('-qux'), 5, "Tag"; is $obj2 -> tag ('-quux'), 6, "Tag"; done_testing; Test-Regexp-2017040101/t/950_pod.t000755 000765 000024 00000000314 12120705101 016612 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use Test::More; use strict; use warnings; no warnings 'syntax'; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod required for testing POD" if $@; all_pod_files_ok (); __END__ Test-Regexp-2017040101/t/960_pod_coverage.t000755 000765 000024 00000000370 12120705101 020470 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use Test::More; use strict; use warnings; no warnings 'syntax'; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage required for testing POD" if $@; all_pod_coverage_ok ({private => [qr /^/]}); __END__ Test-Regexp-2017040101/t/980_versions.t000755 000765 000024 00000004637 12615744275 017747 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use Test::More; use strict; use warnings; no warnings 'syntax'; unless ($ENV {AUTHOR_TESTING}) { plan skip_all => "AUTHOR tests"; exit; } sub version; # # For a minute or two, I considered using File::Find. # # Henry Spencer was right: # # "Those who don't understand Unix are condemned to reinvent it, poorly." # undef $ENV {PATH}; my $FIND = "/usr/bin/find"; my $top = -d "blib" ? "blib/lib" : "lib"; my @files = `$FIND $top -name [a-zA-Z_]*.pm`; chomp @files; my $main_version = version "$top/Test/Regexp.pm"; unless ($main_version) { fail "Cannot find a version in main file"; done_testing; exit; } pass "Got a VERSION declaration in main file"; foreach my $file (@files, "README") { my $base = $file; $base =~ s!^.*/!!; # # Grab version # my $version = version $file; unless ($version) { fail "Did not find a version in $base; skipping tests"; next; } pass "Found version $version in $base"; if ($file eq 'README') { is $version, $main_version, "Version in README matches package version" } else { ok $version le $main_version, " It does not exceed package version"; } } my %monthmap = qw [Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06 Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12]; if (open my $fh, "<", "Changes") { my $first = <$fh>; if ($first =~ /^Version ([0-9]{10}) \S+ (\S+) +([0-9]{0,2}) \S+ \S+ ([0-9]{4})/) { my ($version, $month, $date, $year) = ($1, $2, $3, $4); pass "Version line in Changes file formatted ok"; my $target = sprintf "%04d%02d%02d" => $year, $monthmap {$month}, $date; is substr ($version, 0, 8), $target => " Version and date match"; is $version, $main_version => " Version matches package version"; } else { SKIP: { fail "First line of Changes files correctly formatted: $first"; skip "Cannot extract a correctly formatted version", 2; }} } else { SKIP: { fail "Failed to open Changes file: $!"; skip "Cannot open Changes file", 2; }} done_testing; sub version { my $file = shift; open my $fh, "<", $file or return; while (<$fh>) { return $1 if /^our \$VERSION = '([0-9]{10})';$/; return $1 if /This is version ([0-9]{10}) /; # README return if / \$VERSION \s* =/x; } return; } __END__ Test-Regexp-2017040101/t/981_permissions.t000755 000765 000024 00000001262 12615745123 020433 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use Test::More; use strict; use warnings; no warnings 'syntax'; unless ($ENV {AUTHOR_TESTING}) { plan skip_all => "AUTHOR tests"; exit; } sub version; SKIP: { open my $fh, "<", "MANIFEST" or do { skip "Failed to open MANIFEST", 1; }; while (<$fh>) { chomp; s/\s+Module.*//; unless (-e) { fail "$_ does not exist"; next; } SKIP: { my $mode = (stat) [2]; skip "Failed to grab permissions of $_", 1 unless $mode; my $perm = $mode & 07777; is $perm, /\.t/ ? 0755 : 0644, "Permissions of $_" } } } done_testing; __END__ Test-Regexp-2017040101/t/982_git.t000755 000765 000024 00000001412 12133073124 016627 0ustar00abigailstaff000000 000000 #!/usr/bin/perl use Test::More; use strict; use warnings; no warnings 'syntax'; unless ($ENV {AUTHOR_TESTING}) { plan skip_all => "AUTHOR tests"; exit; } unless (-f ".git/config") { plan skip_all => "This is not a git repository"; exit; } undef $ENV {PATH}; my ($GIT) = grep {-x} qw [/opt/git/bin/git /opt/local/bin/git]; my ($HEAD) = grep {-x} qw [/usr/bin/head]; my @output = `$GIT status --porcelain`; diag @output; ok @output == 0, "All files are checked in"; my @tags = sort grep {/^release/} `$GIT tag`; chomp (my $final_tag = $tags [-1]); my $changes_line = `$HEAD -1 Changes`; ok $final_tag && $changes_line && $final_tag eq "release-" . ($changes_line =~ /^Version ([0-9]{10})/) [0], "git tag matches version"; done_testing; Test-Regexp-2017040101/t/Common.pm000644 000765 000024 00000012026 12722103312 017040 0ustar00abigailstaff000000 000000 package t::Common; use strict; use warnings; no warnings 'syntax'; use 5.010; use Test::More; use Exporter (); use charnames ":full"; our @EXPORT = qw [check]; our @EXPORT_OK = qw [$count $comment $failures $reason $test $line]; our @ISA = qw [Exporter]; my $result = ""; our $count = 0; our $failures = 0; our $comment; our $reason; our $test; our $line; sub escape; my $ESCAPE_NONE = 0; my $ESCAPE_WHITE_SPACE = 1; my $ESCAPE_NAMES = 2; my $ESCAPE_CODES = 3; my $ESCAPE_NON_PRINTABLE = 4; # # results: Arrayref with test results (from Test::Tester) # premature: Anything appearing before test results (from Test::Tester) # match: Should the pattern match or not? Default 0. # match_res: Return value from the "match" function (from Test::Regexp) # pattern: Pattern passed to "match" function (pattern or keep_pattern) # subject: String the pattern is matched against (subject option for "match") # expected: Expected results of the tests. String of 'P', 'F', 'S' # for "Pass", "Fail" and "Skip". # comment: (Optional) 'comment' or 'name' option passed to "match". # keep: (Optional) If true, the pattern is a keep pattern. # reason: (Optional) The "reason" parameter passed to "match". # todo: (Optional) Todo tests, with reason. # escape: (Optional) Escape style used # sub check { my %arg = @_; my $results = $arg {results}; my $premature = $arg {premature}; my $match = $arg {match} || 0; my $match_res = $arg {match_res} || 0; my $pattern = $arg {pattern}; my $expected = $arg {expected}; my $subject = $arg {subject}; my $comment = $arg {comment} // ""; my $keep = $arg {keep}; my $reason = $arg {reason}; my $test = $arg {test}; my $line = $arg {line}; my $todo = $arg {todo}; my $escape = $arg {escape} // (${^UNICODE} ? $ESCAPE_NON_PRINTABLE : $ESCAPE_CODES); my $op = $match ? "=~" : "!~"; my $name = qq {"$subject" $op /$pattern/}; $expected = [split // => $expected] unless ref $expected; pass "Checking tests"; ok !$premature, " No preceeding garbage"; # # Number of tests? # if (@$results == @$expected) { pass " $name: number of tests"; } else { fail sprintf " %s: Got %d tests, expected %d tests" => $name, scalar @$results, scalar @$expected; } # # Correct return value from match? # my $match_res_bool = $match_res ? 1 : 0; my $expected_bool = (grep {$_ eq 'F'} @$expected) ? 0 : 1; if (defined $todo) { pass " Todo test"; } else { is $match_res_bool, $expected_bool, " $name: (no)match value"; } for (my $i = 0; $i < @$results; $i ++) { my $result = $$results [$i]; my $exp = $$expected [$i]; my $ok = $$result {ok}; my $comment = $$result {name}; $comment =~ s/^\s+//; $comment = "Skipped" if $$result {type} eq 'skip'; ok $ok && $exp =~ /[PS]/ || !$ok && $exp =~ /[FS]/, " $name: sub-test ($comment)"; } # # Check the name of the first test # my $test_name = $$results [0] {name} // ""; my $neg = $match ? "" : "not "; my $exp_comment = length ($comment) ? qq {"$comment"} : '/' . (ref $pattern ? $pattern : qr {$pattern}) . '/'; $exp_comment = qq {qq {$subject} ${neg}matched by $exp_comment}; $exp_comment .= " (with -Keep)" if $keep; $exp_comment .= sprintf " [%s:%d]" => $$line [1], $$line [0] if $line; $exp_comment .= sprintf " [Reason: %s]" => $reason if defined $reason && !$match; $exp_comment .= sprintf " [Test: %s]" => $test if defined $test && $match; $exp_comment = escape $exp_comment, $escape; is $test_name, $exp_comment, " Test name"; } # # Almost an identical copy from Test::Common. Better would be a # different implementation. # sub escape { my ($str, $escape) = @_; return if $escape == $ESCAPE_NONE; $str =~ s/\n/\\n/g; $str =~ s/\t/\\t/g; $str =~ s/\r/\\r/g; if ($escape == $ESCAPE_NAMES) { $str =~ s{([^\x20-\x7E])} {my $name = charnames::viacode (ord $1); $name ? sprintf "\\N{%s}" => $name : sprintf "\\x{%02X}" => ord $1}eg; } elsif ($escape == $ESCAPE_CODES) { $str =~ s{([^\x20-\x7E])} {sprintf "\\x{%02X}" => ord $1}eg; } elsif ($escape == $ESCAPE_NON_PRINTABLE) { $str =~ s{([\x00-\x1F\xFF])} {sprintf "\\x{%02X}" => ord $1}eg; } $str =~ s/#/\\#/g; # TAP does this $str; } END {done_testing} 1; __END__ Test-Regexp-2017040101/lib/Test/000700 000765 000024 00000000000 13067715146 016502 5ustar00abigailstaff000000 000000 Test-Regexp-2017040101/lib/Test/Regexp.pm000644 000765 000024 00000074541 13067713712 020314 0ustar00abigailstaff000000 000000 package Test::Regexp; use 5.010; BEGIN { binmode STDOUT, ":utf8"; } use strict; use warnings; use charnames ":full"; no warnings 'syntax'; use Exporter (); use Test::Builder; our @EXPORT = qw [match no_match]; our @ISA = qw [Exporter Test::More]; our $VERSION = '2017040101'; my $Test = Test::Builder -> new; my $ESCAPE_NONE = 0; my $ESCAPE_WHITE_SPACE = 1; my $ESCAPE_NAMES = 2; my $ESCAPE_CODES = 3; my $ESCAPE_NON_PRINTABLE = 4; my $ESCAPE_DEFAULT = ${^UNICODE} ? $ESCAPE_NON_PRINTABLE : $ESCAPE_CODES; sub import { my $self = shift; my $pkg = caller; my %arg = @_; $Test -> exported_to ($pkg); $arg {import} //= [qw [match no_match]]; while (my ($key, $value) = each %arg) { if ($key eq "tests") { $Test -> plan ($value); } elsif ($key eq "import") { $self -> export_to_level (1, $self, $_) for @{$value || []}; } else { die "Unknown option '$key'\n"; } } } my $__ = " "; sub escape { my ($str, $escape) = @_; $escape //= $ESCAPE_DEFAULT; return $str if $escape == $ESCAPE_NONE; $str =~ s/\n/\\n/g; $str =~ s/\t/\\t/g; $str =~ s/\r/\\r/g; if ($escape == $ESCAPE_NAMES) { $str =~ s{([^\x20-\x7E])} {my $name = charnames::viacode (ord $1); $name ? sprintf "\\N{%s}" => $name : sprintf "\\x{%02X}" => ord $1}eg; } elsif ($escape == $ESCAPE_CODES) { $str =~ s{([^\x20-\x7E])} {sprintf "\\x{%02X}" => ord $1}eg; } elsif ($escape == $ESCAPE_NON_PRINTABLE) { $str =~ s{([\x00-\x1F\xFF])} {sprintf "\\x{%02X}" => ord $1}eg; } $str; } sub pretty { my $str = shift; my %arg = @_; substr ($str, 50, -5, "...") if length $str > 55 && !$arg {full_text}; $str = escape $str, $arg {escape}; $str; } sub mess { my $val = shift; unless (defined $val) {return 'undefined'} my %arg = @_; my $pretty = pretty $val, full_text => $arg {full_text}, escape => $arg {escape}; if ($pretty eq $val && $val !~ /'/) { return "eq '$val'"; } elsif ($pretty !~ /"/) { return 'eq "' . $pretty . '"'; } else { return "eq qq {$pretty}"; } } sub todo { my %arg = @_; my $subject = $arg {subject}; my $comment = $arg {comment}; my $upgrade = $arg {upgrade}; my $downgrade = $arg {downgrade}; my $neg = $arg {match} ? "" : "not "; my $full_text = $arg {full_text}; my $escape = $arg {escape}; my $line = ""; if ($arg {show_line}) { no warnings 'once'; my ($file, $l_nr) = (caller ($Test::Builder::deepness // 1)) [1, 2]; $line = " [$file:$l_nr]"; } my $subject_pretty = pretty $subject, full_text => $full_text, escape => $escape; my $Comment = qq {qq {$subject_pretty}}; $Comment .= qq { ${neg}matched by "$comment"}; my @todo = [$subject, $Comment, $line]; # # If the subject isn't already UTF-8, and there are characters in # the range "\x{80}" .. "\x{FF}", we do the test a second time, # with the subject upgraded to UTF-8. # # Otherwise, if the subject is in UTF-8 format, and there are *no* # characters with code point > 0xFF, but with characters in the # range 0x80 .. 0xFF, we downgrade and test again. # if ($upgrade && ($upgrade == 2 || !utf8::is_utf8 ($subject) && $subject =~ /[\x80-\xFF]/)) { my $subject_utf8 = $subject; if (utf8::upgrade ($subject_utf8)) { my $Comment_utf8 = qq {qq {$subject_pretty}}; $Comment_utf8 .= qq { [UTF-8]}; $Comment_utf8 .= qq { ${neg}matched by "$comment"}; push @todo => [$subject_utf8, $Comment_utf8, $line]; } } elsif ($downgrade && ($downgrade == 2 || utf8::is_utf8 ($subject) && $subject =~ /[\x80-\xFF]/ && $subject !~ /[^\x00-\xFF]/)) { my $subject_non_utf8 = $subject; if (utf8::downgrade ($subject_non_utf8)) { my $Comment_non_utf8 = qq {qq {$subject_pretty}}; $Comment_non_utf8 .= qq { [non-UTF-8]}; $Comment_non_utf8 .= qq { ${neg}matched by "$comment"}; push @todo => [$subject_non_utf8, $Comment_non_utf8, $line]; } } @todo; } # # Arguments: # name: 'Name' of the pattern. # pattern: Pattern to be tested, without captures. # keep_pattern: Pattern to be tested, with captures. # subject: String to match. # captures: Array of captures; elements are either strings # (match for the corresponding numbered capture), # or an array, where the first element is the name # of the capture and the second its value. # comment: Comment to use, defaults to name or "". # utf8_upgrade: If set, upgrade the string if applicable. Defaults to 1. # utf8_downgrade If set, downgrade the string if applicable. Defaults to 1. # match If true, pattern(s) should match, otherwise, should fail # to match. Defaults to 1. # reason The reason a match should fail. # test What is tested. # todo This test is a todo test; argument is the reason. # show_line Show file name/line number of call to 'match'. # full_text Don't shorten long messages. # sub match { my %arg = @_; my $name = $arg {name}; my $pattern = $arg {pattern}; my $keep_pattern = $arg {keep_pattern}; my $subject = $arg {subject}; my $captures = $arg {captures} // []; my $comment = escape $arg {comment} // $name // ""; my $upgrade = $arg {utf8_upgrade} // 1; my $downgrade = $arg {utf8_downgrade} // 1; my $match = $arg {match} // 1; my $reason = defined $arg {reason} ? " [Reason: " . $arg {reason} . "]" : ""; my $test = defined $arg {test} ? " [Test: " . $arg {test} . "]" : ""; my $show_line = $arg {show_line}; my $full_text = $arg {full_text}; my $escape = $arg {escape}; my $todo = $arg {todo}; my $keep_message = $arg {no_keep_message} ? "" : " (with -Keep)"; my $numbered_captures; my $named_captures; my $pass = 1; # # First split the captures into a hash (for named captures) and # an array (for numbered captures) so we can check $1 and friends, and %-. # foreach my $capture (@$captures) { if (ref $capture eq 'ARRAY') { my ($name, $match) = @$capture; push @$numbered_captures => $match; push @{$$named_captures {$name}} => $match; } else { push @$numbered_captures => $capture; } } $numbered_captures ||= []; $named_captures ||= {}; my @todo = todo subject => $subject, comment => $comment, upgrade => $upgrade, downgrade => $downgrade, match => $match, show_line => $show_line, full_text => $full_text, escape => $escape; $Test -> todo_start ($todo) if defined $todo; # # Now we will do the tests. # foreach my $todo (@todo) { my $subject = $$todo [0]; my $comment = $$todo [1]; my $line = $$todo [2]; if ($match && defined $pattern) { my $comment = $comment; my $pat = ref $pattern ? $pattern : qr /$pattern/; $comment =~ s{""$}{/$pat/}; $comment .= "$line$test"; # # Test match; match should also be complete, and not # have any captures. # SKIP: { my $result = $subject =~ /^$pattern/; unless ($Test -> ok ($result, $comment)) { $Test -> skip ("Match failed") for 1 .. 3; $pass = 0; last SKIP; } # # %- contains an entry for *each* named group, regardless # whether it's a capture or not. # my $named_matches = 0; $named_matches += @$_ for values %-; unless ($Test -> is_eq ($&, $subject, "${__}match is complete")) { $Test -> skip ("Match failed") for 2 .. 3; $pass = 0; last SKIP; } $pass = 0 unless $Test -> is_eq (scalar @+, 1, "${__}no numbered captures"); $pass = 0 unless $Test -> is_eq ($named_matches, 0, "${__}no named captures"); } } if ($match && defined $keep_pattern) { my $comment = $comment; my $pat = ref $keep_pattern ? $keep_pattern : qr /$keep_pattern/; $comment =~ s{""$}{/$pat/}; $comment .= $keep_message; $comment .= "$line$test"; # # Test keep. Should match, and the parts as well. # # Total number of tests: # - 1 for match. # - 1 for match complete. # - 1 for each named capture. # - 1 for each capture name. # - 1 for number of different capture names. # - 1 for each capture. # - 1 for number of captures. # So, if you only have named captures, and all the names # are different, you have 4 + 3 * N tests. # If you only have numbered captures, you have 4 + N tests. # SKIP: { my $nr_of_tests = 0; $nr_of_tests += 1; # For match. $nr_of_tests += 1; # For match complete. $nr_of_tests += @{$_} for values %$named_captures; # Number of named captures. $nr_of_tests += scalar keys %$named_captures; # Number of different named captures. $nr_of_tests += 1; # Right number of named captures. $nr_of_tests += @$numbered_captures; # Number of numbered captures. $nr_of_tests += 1; # Right number of numbered captures. my ($amp, @numbered_matches, %minus); my $result = $subject =~ /^$keep_pattern/; unless ($Test -> ok ($result, $comment)) { $Test -> skip ("Match failed") for 2 .. $nr_of_tests; $pass = 0; last SKIP; } # # Copy $&, $N and %- before doing anything that # migh override them. # $amp = $&; # # Grab numbered captures. # for (my $i = 1; $i < @+; $i ++) { no strict 'refs'; push @numbered_matches => $$i; } # # Copy %-; # while (my ($key, $value) = each %-) { $minus {$key} = [@$value]; } # # Test to see if match is complete. # unless ($Test -> is_eq ($amp, $subject, "${__}match is complete")) { $Test -> skip ("Match incomplete") for 3 .. $nr_of_tests; $pass = 0; last SKIP; } # # Test named captures. # while (my ($key, $value) = each %$named_captures) { for (my $i = 0; $i < @$value; $i ++) { $pass = 0 unless $Test -> is_eq ( $minus {$key} ? $minus {$key} [$i] : undef, $$value [$i], "${__}\$- {$key} [$i] " . mess ($$value [$i], full_text => $full_text, escape => $escape)); } $pass = 0 unless $Test -> is_num (scalar @{$minus {$key} || []}, scalar @$value, "$__${__}capture '$key' has " . (@$value == 1 ? "1 match" : @$value . " matches")); } # # Test for the right number of captures. # $pass = 0 unless $Test -> is_num (scalar keys %minus, scalar keys %$named_captures, $__ . scalar (keys %$named_captures) . " named capture groups" ); # # Test numbered captures. # for (my $i = 0; $i < @$numbered_captures; $i ++) { $pass = 0 unless $Test -> is_eq ($numbered_matches [$i], $$numbered_captures [$i], "${__}\$" . ($i + 1) . " " . mess ($$numbered_captures [$i], full_text => $full_text, escape => $escape)); } $pass = 0 unless $Test -> is_num (scalar @numbered_matches, scalar @$numbered_captures, $__ . (@$numbered_captures == 1 ? "1 numbered capture group" : @$numbered_captures . " numbered capture groups")); } } if (!$match && defined $pattern) { my $comment = $comment; my $pat = ref $pattern ? $pattern : qr /$pattern/; $comment =~ s{""$}{/$pat/}; $comment .= "$line$reason"; my $r = $subject =~ /^$pattern/; $pass = 0 unless $Test -> ok (!$r || $subject ne $&, $comment); } if (!$match && defined $keep_pattern) { my $comment = $comment; my $pat = ref $keep_pattern ? $keep_pattern : qr /$keep_pattern/; $comment =~ s{""$}{/$pat/}; $comment .= $keep_message; $comment .= "$line$reason"; my $r = $subject =~ /^$keep_pattern/; $pass = 0 unless $Test -> ok (!$r || $subject ne $&, $comment); } } $Test -> todo_end if defined $todo; $pass; } sub no_match { push @_ => match => 0; goto &match; } sub new { "Test::Regexp::Object" -> new } package Test::Regexp::Object; sub new { bless \do {my $var} => shift; } use Hash::Util::FieldHash qw [fieldhash]; fieldhash my %pattern; fieldhash my %keep_pattern; fieldhash my %name; fieldhash my %comment; fieldhash my %utf8_upgrade; fieldhash my %utf8_downgrade; fieldhash my %match; fieldhash my %reason; fieldhash my %test; fieldhash my %show_line; fieldhash my %full_text; fieldhash my %escape; fieldhash my %todo; fieldhash my %tags; fieldhash my %no_keep_message; sub init { my $self = shift; my %arg = @_; $pattern {$self} = $arg {pattern}; $keep_pattern {$self} = $arg {keep_pattern}; $name {$self} = $arg {name}; $comment {$self} = $arg {comment}; $utf8_upgrade {$self} = $arg {utf8_upgrade}; $utf8_downgrade {$self} = $arg {utf8_downgrade}; $match {$self} = $arg {match}; $reason {$self} = $arg {reason}; $test {$self} = $arg {test}; $show_line {$self} = $arg {show_line}; $full_text {$self} = $arg {full_text}; $escape {$self} = $arg {escape}; $todo {$self} = $arg {todo}; $tags {$self} = $arg {tags} if exists $arg {tags}; $no_keep_message {$self} = $arg {no_keep_message}; $self; } sub args { my $self = shift; ( pattern => $pattern {$self}, keep_pattern => $keep_pattern {$self}, name => $name {$self}, comment => $comment {$self}, utf8_upgrade => $utf8_upgrade {$self}, utf8_downgrade => $utf8_downgrade {$self}, match => $match {$self}, reason => $reason {$self}, test => $test {$self}, show_line => $show_line {$self}, full_text => $full_text {$self}, escape => $escape {$self}, todo => $todo {$self}, no_keep_message => $no_keep_message {$self}, ) } sub match { my $self = shift; my $subject = shift; my $captures = @_ % 2 ? shift : undef; Test::Regexp::match subject => $subject, captures => $captures, $self -> args, @_; } sub no_match { my $self = shift; my $subject = shift; Test::Regexp::no_match subject => $subject, $self -> args, @_; } sub name {$name {+shift}} sub set_tag { my $self = shift; $tags {$self} {$_ [0]} = $_ [1]; } sub tag { my $self = shift; $tags {$self} {$_ [0]}; } 1; __END__ =pod =head1 NAME Test::Regexp - Test your regular expressions =head1 SYNOPSIS use Test::Regexp 'no_plan'; match subject => "Foo", pattern => qr /\w+/; match subject => "Foo bar", keep_pattern => qr /(?\w+)\s+(\w+)/, captures => [[first_word => 'Foo'], ['bar']]; no_match subject => "Baz", pattern => qr /Quux/; $checker = Test::Regexp -> new -> init ( keep_pattern => qr /(\w+)\s+\g{-1}/, name => "Double word matcher", ); $checker -> match ("foo foo", ["foo"]); $checker -> no_match ("foo bar"); =head1 DESCRIPTION This module is intended to test your regular expressions. Given a subject string and a regular expression (aka pattern), the module not only tests whether the regular expression complete matches the subject string, it performs a C<< utf8::upgrade >> or C<< utf8::downgrade >> on the subject string and performs the tests again, if necessary. Furthermore, given a pattern with capturing parenthesis, it checks whether all captures are present, and in the right order. Both named and unnamed captures are checked. By default, the module exports two subroutines, C<< match >> and C<< no_match >>. The latter is actually a thin wrapper around C<< match >>, calling it with C<< match => 0 >>. =head2 "Complete matching" A match is only considered to successfully match if the entire string is matched - that is, if C<< $& >> matches the subject string. So: Subject Pattern "aaabb" qr /a+b+/ # Considered ok "aaabb" qr /a+/ # Not considered ok For efficiency reasons, when the matching is performed the pattern is actually anchored at the start. It's not anchored at the end as that would potentially influence the matching. =head2 UTF8 matching Certain regular expression constructs match differently depending on whether UTF8 matching is in effect or not. This is only relevant if the subject string has characters with code points between 128 and 255, and no characters above 255 -- in such a case, matching may be different depending on whether the subject string has the UTF8 flag on or not. C<< Test::Regexp >> detects such a case, and will then run the tests twice; once with the subject string C<< utf8::downgraded >>, and once with the subject string C<< utf8::upgraded >>. =head2 Number of tests There's no fixed number of tests that is run. The number of tests depends on the number of captures, the number of different names of captures, and whether there is the need to up- or downgrade the subject string. It is therefore recommended to use C<< use Text::Regexp tests => 'no_plan'; >>. In a later version, C<< Test::Regexp >> will use a version of C<< Test::Builder >> that allows for nested tests. =head3 Details The number of tests is as follows: If no match is expected (C<< no_match => 0 >>, or C<< no_match >> is used), only one test is performed. Otherwise (we are expecting a match), if C<< pattern >> is used, there will be three tests. For C<< keep_pattern >>, there will be four tests, plus one tests for each capture, an additional test for each named capture, and a test for each name used in the set of named captures. So, if there are C<< N >> captures, there will be at least C<< 4 + N >> tests, and at most C<< 4 + 3 * N >> tests. If both C<< pattern >> and C<< keep_pattern >> are used, the number of tests add up. If C<< Test::Regexp >> decides to upgrade or downgrade, the number of tests double. =head2 C<< use >> options When using C<< Test::Regexp >>, there are a few options you can give it. =over 4 =item C<< tests => 'no_plan' >>, C<< tests => 123 >> The number of tests you are going to run. Since takes some work to figure out how many tests will be run, for now the recommendation is to use C<< tests => 'no_plan' >>. =item C<< import => [methods] >> By default, the subroutines C<< match >> and C<< no_match >> are exported. If you want to import a subset, use the C<< import >> tag, and give it an arrayref with the names of the subroutines to import. =back =head2 C<< match >> The subroutine C<< match >> is the workhorse of the module. It takes a number of named arguments, most of them optional, and runs one or more tests. It returns 1 if all tests were run successfully, and 0 if one or more tests failed. The following options are available: =over 4 =item C<< subject => STRING >> The string against which the pattern is tested is passed to C<< match >> using the C<< subject >> option. It's an error to not pass in a subject. =item C<< pattern => PATTERN >>, C<< keep_pattern => PATTERN >> A pattern (aka regular expression) to test can be passed with one of C<< pattern >> or C<< keep_pattern >>. The former should be used if the pattern does not have any matching parenthesis; the latter if the pattern does have capturing parenthesis. If both C<< pattern >> and C<< keep_pattern >> are provided, the subject is tested against both. It's an error to not give either C<< pattern >> or C<< keep_pattern >>. =item C<< captures => [LIST] >> If a regular expression is passed with C<< keep_pattern >> you should pass in a list of captures using the C<< captures >> option. This list should contain all the captures, in order. For unnamed captures, this should just be the string matched by the capture; for a named capture, this should be a two element array, the first element being the name of the capture, the second element the capture. Named and unnamed captures may be mixed, and the same name for a capture may be repeated. Example: match subject => "Eland Wapiti Caribou", keep_pattern => qr /(\w+)\s+(?\w+)\s+(\w+)/, captures => ["Eland", [a => "Wapiti"], "Caribou"]; =item C<< name => NAME >> The "name" of the test. It's being used in the test comment. =item C<< comment => NAME >> An alternative for C<< name >>. If both are present, C<< comment >> is used. =item C<< utf8_upgrade => 0 >>, C<< utf8_downgrade => 0 >> As explained in L<< /UTF8 matching >>, C<< Test::Regexp >> detects whether a subject may provoke different matching depending on its UTF8 flag, and then it C<< utf8::upgrades >> or C<< utf8::downgrades >> the subject string and runs the test again. Setting C<< utf8_upgrade >> to 0 prevents C<< Test::Regexp >> from downgrading the subject string, while setting C<< utf8_upgrade >> to 0 prevents C<< Test::Regexp >> from upgrading the subject string. =item C<< match => BOOLEAN >> By default, C<< match >> assumes the pattern should match. But it also important to test which strings do not match a regular expression. This can be done by calling C<< match >> with C<< match => 0 >> as parameter. (Or by calling C<< no_match >> instead of C<< match >>). In this case, the test is a failure if the pattern completely matches the subject string. A C<< captures >> argument is ignored. =item C<< reason => STRING >> If the match is expected to fail (so, when C<< match => 0 >> is passed, or if C<< no_match >> is called), a reason may be provided with the C<< reason >> option. The reason is then printed in the comment of the test. =item C<< test => STRING >> If the match is expected to pass (when C<< match >> is called, without C<< match >> being false), and this option is passed, a message is printed indicating what this specific test is testing (the argument to C<< test >>). =item C<< todo => STRING >> If the C<< todo >> parameter is used (with a defined value), the tests are assumed to be TODO tests. The argument is used as the TODO message. =item C<< full_text => BOOL >> By default, long test messages are truncated; if a true value is passed, the message will not get truncated. =item C<< escape => INTEGER >> Controls how non-ASCII and non-printables are displayed in generated test messages: =over 2 =item B<< 0 >> No characters are escape, everything is displayed as is. =item B<< 1 >> Show newlines, linefeeds and tabs using their usual escape sequences (C<< \n >>, C<< \r >>, and C<< \t >>). =item B<< 2 >> Show any character outside of the printable ASCII characters as named escapes (C<< \N{UNICODE NAME} >>), or a hex escape if the unicode name is not found (C<< \x{XX} >>). This is the default if C<< -CO >> is not in effect (C<< ${^UNICODE} >> is false). Newlines, linefeeds and tabs are displayed as above. =item B<< 3 >> Show any character outside of the printable ASCII characters as hext escapes (C<< \x{XX} >>). Newlines, linefeeds and tabs are displayed as above. =item B<< 4 >> Show the non-printable ASCII characters as hex escapes (C<< \x{XX} >>); any non-ASCII character is displayed as is. This is the default if C<< -CO >> is in effect (C<< ${^UNICODE} >> is true). Newlines, linefeeds and tabs are displayed as above. =back =item C<< no_keep_message => BOOL >> If matching against a I<< keeping >> pattern, a message C<< (with -Keep) >> is added to the comment. Setting this parameter suppresses this message. Mostly useful for C<< Regexp::Common510 >>. =back =head2 C<< no_match >> Similar to C<< match >>, except that it tests whether a pattern does B<< not >> match a string. Accepts the same arguments as C<< match >>, except for C<< match >>. =head2 OO interface Since one typically checks a pattern with multiple strings, and it can be tiresome to repeatedly call C<< match >> or C<< no_match >> with the same arguments, there's also an OO interface. Using a pattern, one constructs an object and can then repeatedly call the object to match a string. To construct and initialize the object, call the following: my $checker = Test::Regexp -> new -> init ( pattern => qr /PATTERN/, keep_pattern => qr /(PATTERN)/, ... ); C<< init >> takes exactly the same arguments as C<< match >>, with the exception of C<< subject >> and C<< captures >>. To perform a match, all C<< match >> (or C<< no_match >>) on the object. The first argument should be the subject the pattern should match against (see the C<< subject >> argument of C<< match >> discussed above). If there is a match against a capturing pattern, the second argument is a reference to an array with the matches (see the C<< captures >> argument of C<< match >> discussed above). Both C<< match >> and C<< no_match >> can take additional (named) arguments, identical to the none-OO C<< match >> and C<< no_match >> routines. =head1 RATIONALE The reason C<< Test::Regexp >> was created is to aid testing for the rewrite of C<< Regexp::Common >>. =head1 DEVELOPMENT The current sources of this module are found on github, L<< git://github.com/Abigail/Test-Regexp.git >>. =head1 AUTHOR Abigail L<< mailto:test-regexp@abigail.be >>. =head1 COPYRIGHT and LICENSE Copyright (C) 2009 by Abigail Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 INSTALLATION To install this module, run, after unpacking the tar-ball, the following commands: perl Makefile.PL make make test make install =cut