diff --git a/Changes b/Changes new file mode 100644 index 0000000..b6939ce --- /dev/null +++ b/Changes @@ -0,0 +1,425 @@ +Revision history for Test-Deep + +1.127 2017-05-04 + - no code changes from previous release + +1.126_001 2017-04-17 + - do not eagerly convert simple scalars into tests in the all, any, and + none tests; this was breaking LeafWrapper application + +1.126 2016-12-27 + - no changes since v1.125_001 + +1.125_001 2016-12-27 + - if objects in the "expected" structured have an as_test_deep_cmp + method, it will be called and its return (which should be a + Test::Deep::Cmp object) will be used as the test for that location in + the structure + - internal undocumented class_base routine has been replaced + with a different, clearly private routine + - the LeafWrapper is also used for objects with an unknown reftype + (like LVALUE or other weird ones) + +1.124 2016-11-05 + - avoid an uninitialized warning when array_each() compares to a + non-reference (thanks, Максим Вуец!) + +1.123 2016-09-09 + - remove test suite reliance on "." appearing @INC (thanks, Graham Knop + and Karen Etheridge!) + - when an object with stringification overloading fails to match a + "re" test, its stringification is included in the diagnostics + +1.122 2016-09-07 + - added $Test::Deep::LeafWrapper to control the behavior of simple + values in the "expected" definition; by default, they are treated as + shallow($x) tests, but you can now say (for example) + C<< $Test::Deep::LeafWrapper = \&str >> to always treat the got value + as a string, even if blessed, etc. + +1.121_001 2016-07-19 + - documentation improvements + - avoid a few evals, localize $@ in a few places where eval is used + - good bye tabs, hello spaces + +1.120 2015-11-27 + - no changes since 0.119_01 + - this massive version bump was a mistake + +0.119_01 2015-11-19 + - add none() test; it's like any(), but negative + - fix stringification of any() expectations + +0.119 2015-09-29 + - remove use of Test::NoWarnings for user-facing tests + +0.118 2015-07-27 TRIAL RELEASE + - overloading of & and | no longer can change All or Any objects + found as arguments + - an All as an argument to an All constructed is flattened out into its + All-ed values; the same goes for Any + +0.117 2015-06-21 + - do not lose argument(s) to import + (fixes https://github.com/rjbs/Test-Deep/issues/29 ) + +0.116 2015-06-20 + - on its own, :preload options uses default group of exports + +0.115 2015-01-09 + - worked around a bug in chained goto on 5.8.5 + +0.114 2014-12-11 + - improve prereqs metadata (thanks, Karen Etheridge) + - add a noneof() set test (thanks, Peter Haworth) + - regexponly hasn't worked... ever. now it does + - passing :preload to import loads all plugins up front + - a few more tests have been documented + - the many exports of Test::Deep are now documented! + +0.113 2014-08-22 + - fix a compile error (!!) in RegexpOnly + - fix some documentation typos (thanks, ZOFFIX) + - add license to META file + +0.112 2013-11-30 + - rebuild MANIFEST, adding two forgotten files + +0.111 2013-11-30 + + - When printing diagnostics, differentiate the type of a blessed object + from the name of the class itself (RT#78288, caused by changes to how + blessed objects are treated in 0.109) (thanks, Karen Etheridge) + + - Typo fixes (thanks, David Steinbrunner) + + - Fixes to clarity and accuracy of documentation (thanks, Michael Hamlin) + + - Add metadata links to repo and issue tracker + + - Added obj_isa for testing ->isa without falling back to ref($x) + + - Added the *experimental* ":v1" export group to skip importing + Isa, isa, and blessed + +0.110 2012-06-16 + + Allow methods() and listmethods() to work again on class methods + (RT#77804) (thanks, Ricardo Signes!) + +0.109 2012-02-16 + + UNIVERSAL::isa and UNIVERAL::can are no longer called as functions: + this was deprecated in UNIVERSAL 1.03. (RT#74760, Karen Etheridge) + + the code that builds the exporter configuration is cleaned up; more + documentation of how it may change (for the better, without breaking + stuff) should appear in the near future + +0.108 2010-10-15 + + simple (stringwise) comparison should now be much faster (thanks, + NCLEATON) + +0.107 2009-10-28 + + New maintainer: Ricardo Signes (rjbs) + + On 5.10.0 and newer perl, install to the "site" directory, not the + core perl directory in @INC. (Prior to 5.10.0, @INC ordering was + unfortunate, and fixing the install target would make upgrading + difficult.) + + cope with new stringification of qr{} objects in 5.13.x+ (thanks, + ANDK) + + fix Pod escaping errors (thanks, FWIE) + +0.106 + + Release after dev. + +0.105-dev + + Fix for perl 5.010.1 - the code to check the version and act + correctly on regexp refs treated .1 as behaving like 5.011. + +0.104 + + Document behaviour of cmp_bag when a non ARRAY-ref argument is passed + to it. Explicity test for this a die with a useful message. + + Document and export cmp_details and deep_diag, thanks to Tom Hukins + for the patch. + +0.103 + + Detect whether isa() is being called with 1 or 2 arguments and + dispatch to the correct function. This is hacky but fixes the problem + of clashing with UNIVERSAL::isa(). + +0.102 + + Behave well when a code comparator doesn't give diagnostics. Thanks + to Alex Kapranoff. + +0.101 + + Fix an overloading problem with All and Any. Thanks to Kostas + Chatzikokolakis for reporting the bug and especially for explaining + how to fix it :) + + Added a nasty hack to smooth over a problem in Test::Tester. + +0.100 + + Apply patch from Andreas Koenig (ANDK) to cope with Perl 5.11's new + REGEXP objects. + +0.099 + + Don't explode on perl's that don't have weakrefs. If they're not + available, just don't weaken the refs. It means refs can be cached + for longer than desirable but it's better than explodiing. + + This doesn't fix all of te problems with perl 5.005 but I'm pushing + it out because the previous version number upsets CPAN.pm. + +0.098 + + Cleaned up Test::Deep::NoTest by making it call Test::Deep's import, + that way it will always be in sync for exports. Also added some POD + docs. + + Added notest_extra.t to check that things are correctly exported and + working. + + Add cmp_details but left it undocumented. It manages localising the + stack etc. Factored eq_deeply and cmp_deeply through that. This meant + adding an icky hack into deep_diag. I should clean that whole thing + up. + + Remove $name from params of eq_deeply, in code and docs, it was + unused. + +0.097 + + Fixed doc typo for re(). + + Fix diagnostics for code(), it was always printing undef instead of + the got value. + +0.096 + + %WrapCache was keeping references to external data. It's now + local()ised at the start of a comparison just like the other caches + (why I didn't do that when I added it, I don't know). Thanks to + Matthijs Bomhoff for reporting the problem. + +0.095 + + Docs and code didn't match, useclass was actually requireclass, + available as both now + +0.094 + + Changed Set and Bag to no longer issue warnings when undefs are + present. Needed to make the sort and the diagnotics + undef-aware. Thanks to Colin Kuskie for pointing this out. + + Added tests for this. + +0.093 + + Fixed inifinte recursion when adding comparators into bags. That + whole area is unpleasant - conceptually as well as + implementation-wise. Comparators no longer inherit a compare method, + so we only call the specialised compare if it exists, otherwise we + just do normal deep comparison. + + Removed a debugging print. + +0.092 + + Got the if backwards for loading Test::Builder (again for NoTest - + simples changes...). No ill effects for most people as they load it + via something else any but ApacheSession for example doesn't. + + Now tetsing for lack of testing framework. + +0.091 + + Forgot to export lots of stuff via NoTest + +0.090 + + Added Test::Builder::NoTest so that eq_deeply can be use entirely + without Test::Builder. + +0.089 + + Wasn't corrrectly setting $Test::Builder::Level in cmp_bag, cmp_set + and cmp_methods, this caused test error messages to include the wrong + line/file. + + Whitespace changes. + +0.088 + + Slight twiddle to silence warnings from the new Test::Tester thanks to + SSORICHE + +0.087 + + cmp_methods, cmp_bag and cmp_set weren't passing on the test name. + Thanks to Alex Kapranoff for the patch. + +0.086 + + Add $tolerance to Number so now you can check that 2 numbers are + equal, give or take a little bit. + + Autogenerating most of the convenience constructor routines, deleted + nearly 200 lines of boilerplate. Why didn't I think of that before? + + Almost every test script had the same lines at the beginning. These + are now in t/std.pm, another 200 lines of code (well 50% whitespace) + gone. Happy. + + Added use warnings to the test scripts, didn't make a difference. + + Added inspection of strings captured from a regex and fixed up some + re() doc errors. + +0.085 + + When a hash or array value or amethod does not exist and the expected + value was a reference, the diagnostics were wrong because it headed + into Reftype tests. Now Test::Deep::descend catches "Does not exist" + early on. + + Added listmethods() + +0.084 + + Added subhashof and superhashof, restructured various Hash modules to + handle sub and super. + + Got rid of unexported hash_elements from Test::Deep. + + Fixed a problem with circular set comparisons. + +0.083 + + The cache is more efficient, using a single layer and weak refs, also + previously it could be fooled by reused addresses for objects (this + is not just theoretical). + + Now Test::Deep::descend is responsible for pushing onto the stack as + well as pulling, this means most tests don't need to think about the + stack at all + + For the stack stuff, had to create lots of "only" modules these are + tests that should never be called on their own as they make + assumptions about the validity of the data, they are used as subtests + inside others + + cleaned up lots of copy and paste Data::Dumper and confess and + various other bits and pieces + + Test::Deep::Cmp (and it's descendants) autopush themselves onto the + stack of any Test::Deep::* that uses them. Cuts even more cruft. + + Now everything uses the compare in Test::Deep::Cmp which just does a + deep comparison. This is not perfect for All and Set but it's as good + as what was happeneing before now. + + Wrapping unknown reftypes as shallow + +0.082 + + Got rid of silly use lib in the tests, shouldn't have been in public + + Added dependency on Test::More + + Moved from type =>, vals => to exp =>, got => in stack entries + + Individual descend()s no longer pop their data from the stack, that's + taken care of by Test::Deep::descend. This made things simpler in all + the comparisons. + + Added support for sub/super se/bag comparisons, thanks to Boris + Sukholitko + + Added scalarref.t + +0.081 + + Got rid of struct mode for num() + + Large internal changes, now using a stack object rather than just an + array. This handles rendering the stack. + + The comparisons handle rendering the got and expected values now. + + num() and str() numify/stringify before comparing, this makes + overload of == or eq irrelevant. This also prevents problems with the + diag when something stringifies differently to it's numificiation or + differently each time you look. + + fixed diag of overloaded refs to display the ref value, not the + overloaded value + + nicer diags for booleans + +0.08 + + Slight doc fix + + Added coderef calling as a test + +0.07 + + Fixed number.t to skip strict test when if Scalar::Util is not right + + Major improvement of docs. No longer reads like it was written by a + drunken badger. + +0.06 + + Overhaul of Test::Deep::descend, native types are now wrapped up in a + Test::Deep:Cmp object, moves lots of logic out of descend + + Added ArrayLength, HashKeys, RefType, and Blessed comparisons + + All tests now use Test::NoWarnings + + Broke out descend tests into hash.t, array, regexpref.t, probably + should break out more + + Updated version of Scalar::Util dependency, thanks to Steve Purkis + +0.05 + + No longer using overload::StrVal() for looking behind overloads as + it's broken for Regexp refs in some versions of Perl. + +0.04 + + Documented bool and included the files!! + +0.03 + + cmp_deeply(undef, \"") calls overload::StrVal(undef) + + added bool test + + using Scalar::Util to get reftype and blessed class + +0.02 + + Added prereq to Makefile.PL + +0.01 + + First release diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..1c0a63a --- /dev/null +++ b/MANIFEST @@ -0,0 +1,92 @@ +Changes +lib/Test/Deep.pm +lib/Test/Deep/All.pm +lib/Test/Deep/Any.pm +lib/Test/Deep/Array.pm +lib/Test/Deep/ArrayEach.pm +lib/Test/Deep/ArrayElementsOnly.pm +lib/Test/Deep/ArrayLength.pm +lib/Test/Deep/ArrayLengthOnly.pm +lib/Test/Deep/Blessed.pm +lib/Test/Deep/Boolean.pm +lib/Test/Deep/Cache.pm +lib/Test/Deep/Cache/Simple.pm +lib/Test/Deep/Class.pm +lib/Test/Deep/Cmp.pm +lib/Test/Deep/Code.pm +lib/Test/Deep/Hash.pm +lib/Test/Deep/HashEach.pm +lib/Test/Deep/HashElements.pm +lib/Test/Deep/HashKeys.pm +lib/Test/Deep/HashKeysOnly.pm +lib/Test/Deep/Ignore.pm +lib/Test/Deep/Isa.pm +lib/Test/Deep/ListMethods.pm +lib/Test/Deep/Methods.pm +lib/Test/Deep/MM.pm +lib/Test/Deep/None.pm +lib/Test/Deep/NoTest.pm +lib/Test/Deep/Number.pm +lib/Test/Deep/Obj.pm +lib/Test/Deep/Ref.pm +lib/Test/Deep/RefType.pm +lib/Test/Deep/Regexp.pm +lib/Test/Deep/RegexpMatches.pm +lib/Test/Deep/RegexpOnly.pm +lib/Test/Deep/RegexpRef.pm +lib/Test/Deep/RegexpRefOnly.pm +lib/Test/Deep/RegexpVersion.pm +lib/Test/Deep/ScalarRef.pm +lib/Test/Deep/ScalarRefOnly.pm +lib/Test/Deep/Set.pm +lib/Test/Deep/Shallow.pm +lib/Test/Deep/Stack.pm +lib/Test/Deep/String.pm +Makefile.PL +MANIFEST This list of files +README +t/all.t +t/any.t +t/array.t +t/array_each.t +t/arraylength.t +t/bag.t +t/bagrecursion.t +t/blessed.t +t/boolean.t +t/cache.t +t/circular.t +t/class.t +t/code.t +t/deep_utils.t +t/descend.t +t/error.t +t/hash.t +t/hash_each.t +t/hashkeys.t +t/ignore.t +t/import.t +t/isa.t +t/leaf-wrapper.t +t/lib/Over.pm +t/lib/Std.pm +t/listmethods.t +t/memory.t +t/methods.t +t/none.t +t/notest.t +t/notest_extra.t +t/number.t +t/reftype.t +t/regexp.t +t/regexp.t.orig +t/regexpref.t +t/rt78288_blessed_object.t +t/scalar.t +t/scalarref.t +t/set.t +t/shallow.t +t/string.t +TODO +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/META.json b/META.json new file mode 100644 index 0000000..50f2996 --- /dev/null +++ b/META.json @@ -0,0 +1,63 @@ +{ + "abstract" : "unknown", + "author" : [ + "Fergal Daly " + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Test-Deep", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "List::Util" : "1.09", + "Scalar::Util" : "1.09", + "Test::Builder" : "0" + } + }, + "test" : { + "requires" : { + "Test::More" : "0.88", + "Test::Tester" : "0.04" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "http://github.com/rjbs/Test-Deep/issues" + }, + "homepage" : "http://github.com/rjbs/Test-Deep/", + "repository" : { + "type" : "git", + "url" : "https://github.com/rjbs/Test-Deep.git", + "web" : "https://github.com/rjbs/Test-Deep" + }, + "x_IRC" : "irc://irc.perl.org/#perl-qa", + "x_MailingList" : "http://lists.perl.org/list/perl-qa.html" + }, + "version" : "1.127", + "x_serialization_backend" : "JSON::PP version 2.27400" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..6a8dbbe --- /dev/null +++ b/META.yml @@ -0,0 +1,33 @@ +--- +abstract: unknown +author: + - 'Fergal Daly ' +build_requires: + ExtUtils::MakeMaker: '0' + Test::More: '0.88' + Test::Tester: '0.04' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Test-Deep +no_index: + directory: + - t + - inc +requires: + List::Util: '1.09' + Scalar::Util: '1.09' + Test::Builder: '0' +resources: + IRC: irc://irc.perl.org/#perl-qa + MailingList: http://lists.perl.org/list/perl-qa.html + bugtracker: http://github.com/rjbs/Test-Deep/issues + homepage: http://github.com/rjbs/Test-Deep/ + repository: https://github.com/rjbs/Test-Deep.git +version: '1.127' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..4ac45ef --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,65 @@ +use strict; + +use ExtUtils::MakeMaker; + +# this ugliness comes from incompatibility of certain versions of +# Test::Tester with certain version of Test::Builder. The problem is +# that people might have an old TT lying around and are also likely to +# have quite a new TB. This detects that situation and hopefully +# demands an install of a newer TT. + +my $tt_prereq = "0.04"; + +if (eval { require Test::Tester; require Test::Builder; 1 } && + $Test::Tester::VERSION <= 0.106 && + $Test::Builder::VERSION >= 0.78) { + + $tt_prereq = "0.107"; +} + +my $mm_ver = ExtUtils::MakeMaker->VERSION; + +WriteMakefile( + AUTHOR => 'Fergal Daly ', + NAME => 'Test::Deep', + VERSION_FROM => './lib/Test/Deep.pm', + PREREQ_PM => { + 'Test::Builder' => '0', + 'Scalar::Util' => '1.09', + + # apparently CPAN doesn't get the version of Scalar::Util + 'List::Util' => '1.09', + }, + + ( $ExtUtils::MakeMaker::VERSION < 6.63_03 ? 'BUILD_REQUIRES' : 'TEST_REQUIRES' ) => { + 'Test::More' => '0.88', + 'Test::Tester' => $tt_prereq, + }, + + LICENSE => "perl", + + # This is a dumb mistake. Why did it get done? I'm the one who did it and I + # don't know. It only affects perl 5.8, and stopping doing it now would be a + # problem, because upgrades wouldn't actually upgrade. I'll just leave it + # here until 5.8 is really and truly dead enough. -- rjbs, 2013-11-30 + ($] < 5.010 ? (INSTALLDIRS => 'perl') : ()), + + ($mm_ver < 6.46 ? () : (META_MERGE => { + 'meta-spec' => { version => 2 }, + dynamic_config => 1, + resources => { + homepage => 'http://github.com/rjbs/Test-Deep/', + repository => { + url => 'https://github.com/rjbs/Test-Deep.git', + web => 'https://github.com/rjbs/Test-Deep', + type => 'git', + }, + bugtracker => { + web => 'http://github.com/rjbs/Test-Deep/issues', + }, + x_MailingList => 'http://lists.perl.org/list/perl-qa.html', + x_IRC => 'irc://irc.perl.org/#perl-qa', + }, + })), + +); diff --git a/README b/README new file mode 100644 index 0000000..222c70c --- /dev/null +++ b/README @@ -0,0 +1,10 @@ +This module gives you lots of flexibility when testing deep structres. + +Install as usual - untar it the + +perl Makefile.PL +make +make test +make install + +See the pod for full deatils of how to use this. diff --git a/TODO b/TODO new file mode 100644 index 0000000..d25d34e --- /dev/null +++ b/TODO @@ -0,0 +1,111 @@ +* compare handlers: + hash/array slice + can + +* warn about noclass in a circular structure... dunno now... + +* add tests for Sets of various things + +* rename diagnostics to diag_full + +* add Data::Dumper features, including dumping with errors highlighted + +* get any to generate diags for each part and splurge all if none match + +* add tests for useclass + +* will set call methods an unknown number of times? Isn't the result cached +already? + +* cache method calls so that multiple call won't make a difference. This +will only work if they don't also look inside the object + +* fix the compare() system so I can use descend + +* protect against dieing in slices + +* use sets in all and any's compare method + +* add not() + +* give a way to name tests so that they can be reused + +* use set/bag in set/bag compare() + +* add a holder like Code::Perl's + +* add variables so { key1 => var("this"), key2 => var("this")} makes sure +that $h->{key1} equals $h->{key2}. Make sure they are implemented using +local for scoping (no! otherwise the above will break). Maybe setvar and +cmpvar + +* add < > lt gt + +* add label() to allow labelling of sections + +* fix add for sets so that ignore dupes doesn't kick in too early + +* add deep() explicitly request deep - why? + +* clean up quoting + +* fix Test::Deep::Set::add - I'll do that with the set cleanup + +* worry about what happens when a temp array ref gets the address of a +previous temp array ref and we check them in the cache. Do we need a class +for temps? + +* add more tests for reftype + +* add glob stuff + +* test the compare methods + +* make String check definedness + +* make regexprefs work by using some more general overload mechanism + +* when failing a number due to strictness we should give different diags but +diags aren't flexible enough yet + +* add docs for comparisons + +* for circular refs, we are not looking for simulations but for graph +isomorphisms (or possibly a class of homomorphisms, that preserve the +distinctness of containers). We need a cache that can answer "assuming a=b, +are these two cache-equal?" and can keep track of dependencies. Shouldn't be +too hard to make it possible but making it fast could be a problem. Would +naming things help? Is this getting prological? + +* use Class::ISA for ISA stuff, especially under 5.6.0 + +* get methods to emit better diags for non existant methods, including class +of object + +* all() doesn't need to tell you part n, what matters is the test that was +going on. Also any() should diags for each failure so they can be displayed +if nothing passes + +* get set using some standard subtests + +* split String into String and is_eq or streq + +* make an iterator comparator that can run over an array or whatever use it +for Array, ArrayEach, ArrayAny + +* need to differentiate between UNIVERSAL::isa and ->isa + +* beef up the reftype checking for ScalarRef so bad $self->{val} won't break +it + +* think about merging test_class and test_reftype into 1 + +* fix compare for Ignore, All and Code + +* glob comparison + +* code comparison using B::Deparse? sounds like a bad idea due to private +data in closures + +* add eval at the outler layer to catch all nasties and report them along +with the data path at which they occured diff --git a/lib/Test/Deep.pm b/lib/Test/Deep.pm new file mode 100644 index 0000000..7a5fac7 --- /dev/null +++ b/lib/Test/Deep.pm @@ -0,0 +1,1819 @@ +use strict; +use warnings; + +package Test::Deep; +use Carp qw( confess ); + +use Test::Deep::Cache; +use Test::Deep::Stack; +use Test::Deep::RegexpVersion; + +require overload; +use Scalar::Util; + +my $Test; +unless (defined $Test::Deep::NoTest::NoTest) +{ +# for people who want eq_deeply but not Test::Builder + require Test::Builder; + $Test = Test::Builder->new; +} + +our ($Stack, %Compared, $CompareCache, %WrapCache, $Shallow); + +our $VERSION = '1.127'; +$VERSION =~ tr/_//d; + +require Exporter; +our @ISA = qw( Exporter ); + +our $Snobby = 1; # should we compare classes? +our $Expects = 0; # are we comparing got vs expect or expect vs expect + +our $LeafWrapper; # to wrap simple values in a test; if not set, shallow() + +our $DNE = \""; +our $DNE_ADDR = Scalar::Util::refaddr($DNE); + +# if no sub name is supplied then we use the package name in lower case +my @constructors = ( + All => "", + Any => "", + Array => "", + ArrayEach => "array_each", + ArrayElementsOnly => "", + ArrayLength => "", + ArrayLengthOnly => "", + Blessed => "", + Boolean => "bool", + Code => "", + Hash => "", + HashEach => "hash_each", + HashKeys => "", + HashKeysOnly => "", + Ignore => "", + Isa => "Isa", + ListMethods => "", + Methods => "", + None => "", + Number => "num", + Obj => "obj_isa", + RefType => "", + Regexp => "re", + RegexpMatches => "", + RegexpOnly => "", + RegexpRef => "", + RegexpRefOnly => "", + ScalarRef => "scalref", + ScalarRefOnly => "", + Shallow => "", + String => "str", +); + +my @CONSTRUCTORS_FROM_CLASSES; + +while (my ($pkg, $name) = splice @constructors, 0, 2) +{ + $name = lc($pkg) unless $name; + my $full_pkg = "Test::Deep::$pkg"; + my $file = "$full_pkg.pm"; + $file =~ s#::#/#g; + my $sub = sub { + require $file; + return $full_pkg->new(@_); + }; + { + no strict 'refs'; + *{$name} = $sub; + } + + push @CONSTRUCTORS_FROM_CLASSES, $name; +} + +{ + our @EXPORT_OK = qw( descend render_stack cmp_details deep_diag ); + + our %EXPORT_TAGS; + $EXPORT_TAGS{preload} = []; + $EXPORT_TAGS{v0} = [ + qw( + Isa + blessed + obj_isa + + all any array array_each arrayelementsonly arraylength arraylengthonly + bag bool cmp_bag cmp_deeply cmp_methods cmp_set code eq_deeply + hash hash_each hashkeys hashkeysonly ignore isa listmethods methods + noclass none noneof num re reftype regexpmatches regexponly regexpref + regexprefonly scalarrefonly scalref set shallow str subbagof subhashof + subsetof superbagof superhashof supersetof useclass + ) + ]; + + $EXPORT_TAGS{v1} = [ + qw( + obj_isa + + all any array array_each arrayelementsonly arraylength arraylengthonly + bag bool cmp_bag cmp_deeply cmp_methods cmp_set code eq_deeply + hash hash_each hashkeys hashkeysonly ignore listmethods methods + noclass none noneof num re reftype regexpmatches regexponly regexpref + regexprefonly scalarrefonly scalref set shallow str subbagof subhashof + subsetof superbagof superhashof supersetof useclass + ) + ]; + + our @EXPORT = @{ $EXPORT_TAGS{ v0 } }; + + $EXPORT_TAGS{all} = [ @EXPORT, @EXPORT_OK ]; +} + +sub import { + my $self = shift; + my @sans_preload = grep {; $_ ne ':preload' } @_; + if (@_ != @sans_preload) { + require Test::Deep::All; + require Test::Deep::Any; + require Test::Deep::Array; + require Test::Deep::ArrayEach; + require Test::Deep::ArrayElementsOnly; + require Test::Deep::ArrayLength; + require Test::Deep::ArrayLengthOnly; + require Test::Deep::Blessed; + require Test::Deep::Boolean; + require Test::Deep::Cache::Simple; + require Test::Deep::Cache; + require Test::Deep::Class; + require Test::Deep::Cmp; + require Test::Deep::Code; + require Test::Deep::Hash; + require Test::Deep::HashEach; + require Test::Deep::HashElements; + require Test::Deep::HashKeys; + require Test::Deep::HashKeysOnly; + require Test::Deep::Ignore; + require Test::Deep::Isa; + require Test::Deep::ListMethods; + require Test::Deep::Methods; + require Test::Deep::MM; + require Test::Deep::None; + require Test::Deep::Number; + require Test::Deep::Obj; + require Test::Deep::Ref; + require Test::Deep::RefType; + require Test::Deep::Regexp; + require Test::Deep::RegexpMatches; + require Test::Deep::RegexpOnly; + require Test::Deep::RegexpRef; + require Test::Deep::RegexpRefOnly; + require Test::Deep::RegexpVersion; + require Test::Deep::ScalarRef; + require Test::Deep::ScalarRefOnly; + require Test::Deep::Set; + require Test::Deep::Shallow; + require Test::Deep::Stack; + require Test::Deep::String; + } + + $self->export_to_level(1, $self, @_); +} + +# this is ugly, I should never have exported a sub called isa now I +# have to try figure out if the recipient wanted my isa or if a class +# imported us and UNIVERSAL::isa is being called on that class. +# Luckily our isa always expects 1 argument and U::isa always expects +# 2, so we can figure out (assuming the caller is not buggy). +sub isa +{ + if (@_ == 1) + { + goto &Isa; + } + else + { + goto &UNIVERSAL::isa; + } +} + +sub cmp_deeply +{ + my ($d1, $d2, $name) = @_; + + my ($ok, $stack) = cmp_details($d1, $d2); + + if (not $Test->ok($ok, $name)) + { + my $diag = deep_diag($stack); + $Test->diag($diag); + } + + return $ok; +} + +sub cmp_details +{ + my ($d1, $d2) = @_; + + local $Stack = Test::Deep::Stack->new; + local $CompareCache = Test::Deep::Cache->new; + local %WrapCache; + + my $ok = descend($d1, $d2); + + return ($ok, $Stack); +} + +sub eq_deeply +{ + my ($d1, $d2) = @_; + + my ($ok) = cmp_details($d1, $d2); + + return $ok +} + +sub eq_deeply_cache +{ + # this is like cross between eq_deeply and descend(). It doesn't start + # with a new $CompareCache but if the comparison fails it will leave + # $CompareCache as if nothing happened. However, if the comparison + # succeeds then $CompareCache retains all the new information + + # this allows Set and Bag to handle circular refs + + my ($d1, $d2, $name) = @_; + + local $Stack = Test::Deep::Stack->new; + $CompareCache->local; + + my $ok = descend($d1, $d2); + + $CompareCache->finish($ok); + + return $ok; +} + +sub deep_diag +{ + my $stack = shift; + # ick! incArrow and other things expect the stack has to be visible + # in a well known place . TODO clean this up + local $Stack = $stack; + + my $where = render_stack('$data', $stack); + + confess "No stack to diagnose" unless $stack; + my $last = $stack->getLast; + + my $diag; + my $message; + my $got; + my $expected; + + my $exp = $last->{exp}; + if (Scalar::Util::blessed($exp)) + { + if ($exp->can("diagnostics")) + { + $diag = $exp->diagnostics($where, $last); + $diag =~ s/\n+$/\n/; + } + else + { + if ($exp->can("diag_message")) + { + $message = $exp->diag_message($where); + } + } + } + + if (not defined $diag) + { + $got = $exp->renderGot($last->{got}) unless defined $got; + $expected = $exp->renderExp unless defined $expected; + $message = "Compared $where" unless defined $message; + + $diag = <isa("Test::Deep::Cmp")) + { + my $where = $Stack->render('$data'); + confess "Found a special comparison in $where\nYou can only use specials in the expects structure"; + } + + if (ref $d1 and ref $d2) + { + # this check is only done when we're comparing 2 expecteds against each + # other + + if ($Expects and Scalar::Util::blessed($d1) and $d1->isa("Test::Deep::Cmp")) + { + # check they are the same class + return 0 unless Test::Deep::blessed(Scalar::Util::blessed($d2))->descend($d1); + if ($d1->can("compare")) + { + return $d1->compare($d2); + } + } + + my $s1 = Scalar::Util::refaddr($d1); + my $s2 = Scalar::Util::refaddr($d2); + + if ($s1 eq $s2) + { + return 1; + } + if ($CompareCache->cmp($d1, $d2)) + { + # we've tried comparing these already so either they turned out to + # be the same or we must be in a loop and we have to assume they're + # the same + + return 1; + } + else + { + $CompareCache->add($d1, $d2) + } + } + + $d2 = wrap($d2); + + $Stack->push({exp => $d2, got => $d1}); + + if (ref($d1) and (Scalar::Util::refaddr($d1) == $DNE_ADDR)) + { + # whatever it was supposed to be, it didn't exist and so it's an + # automatic fail + return 0; + } + + if ($d2->descend($d1)) + { +# print "d1 = $d1, d2 = $d2\nok\n"; + $Stack->pop; + + return 1; + } + else + { +# print "d1 = $d1, d2 = $d2\nnot ok\n"; + return 0; + } +} + +sub wrap +{ + my $data = shift; + + my $class = Scalar::Util::blessed($data); + return $data if defined $class and $data->isa("Test::Deep::Cmp"); + + if (defined $class and $data->can('as_test_deep_cmp')) { + my $cmp = $data->as_test_deep_cmp; + return $cmp if $cmp->isa('Test::Deep::Cmp'); + Carp::confess("object in expected structure provides as_test_deep_cmp but it did not return a Test::Deep::Cmp"); + } + + my $reftype = _td_reftype($data); + + my $cmp; + + if($reftype eq '') + { + $cmp = $Test::Deep::LeafWrapper + ? $Test::Deep::LeafWrapper->($data) + : shallow($data); + } + else + { + my $addr = Scalar::Util::refaddr($data); + + return $WrapCache{$addr} if $WrapCache{$addr}; + + if($reftype eq 'ARRAY') + { + $cmp = array($data); + } + elsif($reftype eq 'HASH') + { + $cmp = hash($data); + } + elsif($reftype eq 'SCALAR' or $reftype eq 'REF') + { + $cmp = scalref($data); + } + elsif(($reftype eq 'Regexp') or ($reftype eq 'REGEXP')) + { + $cmp = regexpref($data); + } + else + { + $cmp = $Test::Deep::LeafWrapper + ? $Test::Deep::LeafWrapper->($data) + : shallow($data); + } + + $WrapCache{$addr} = $cmp; + } + return $cmp; +} + +sub _td_reftype +{ + my $val = shift; + + my $reftype = Scalar::Util::reftype($val); + return '' unless defined $reftype; + + return $reftype unless $Test::Deep::RegexpVersion::OldStyle; + + my $blessed = Scalar::Util::blessed($val); + return $reftype unless defined $blessed; + + if ($blessed && $blessed eq "Regexp" and $reftype eq "SCALAR") + { + $reftype = "Regexp" + } + + return $reftype; +} + +sub render_stack +{ + my ($var, $stack) = @_; + + return $stack->render($var); +} + +sub cmp_methods +{ + local $Test::Builder::Level = $Test::Builder::Level + 1; + return cmp_deeply(shift, methods(@{shift()}), shift); +} + +sub requireclass +{ + require Test::Deep::Class; + + my $val = shift; + + return Test::Deep::Class->new(1, $val); +} + +# docs and export say this is called useclass, doh! + +*useclass = \&requireclass; + +sub noclass +{ + require Test::Deep::Class; + + my $val = shift; + + return Test::Deep::Class->new(0, $val); +} + +sub set +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(1, "", @_); +} + +sub supersetof +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(1, "sup", @_); +} + +sub subsetof +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(1, "sub", @_); +} + +sub noneof +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(1, "none", @_); +} + +sub cmp_set +{ + local $Test::Builder::Level = $Test::Builder::Level + 1; + return cmp_deeply(shift, set(@{shift()}), shift); +} + +sub bag +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(0, "", @_); +} + +sub superbagof +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(0, "sup", @_); +} + +sub subbagof +{ + require Test::Deep::Set; + + return Test::Deep::Set->new(0, "sub", @_); +} + +sub cmp_bag +{ + local $Test::Builder::Level = $Test::Builder::Level + 1; + my $ref = ref($_[1]) || ""; + confess "Argument 2 to cmp_bag is not an ARRAY ref (".render_val($_[1]).")" + unless $ref eq "ARRAY"; + return cmp_deeply(shift, bag(@{shift()}), shift); +} + +sub superhashof +{ + require Test::Deep::Hash; + + my $val = shift; + + return Test::Deep::SuperHash->new($val); +} + +sub subhashof +{ + require Test::Deep::Hash; + + my $val = shift; + + return Test::Deep::SubHash->new($val); +} + +sub builder +{ + if (@_) + { + $Test = shift; + } + return $Test; +} + +1; + +__END__ + +=head1 NAME + +Test::Deep - Extremely flexible deep comparison + +=head1 SYNOPSIS + + use Test::More tests => $Num_Tests; + use Test::Deep; + + cmp_deeply( + $actual_horrible_nested_data_structure, + $expected_horrible_nested_data_structure, + "got the right horrible nested data structure" + ); + + cmp_deeply( + $object, + methods(name => "John", phone => "55378008"), + "object methods ok" + ); + + cmp_deeply( + \@array, + [$hash1, $hash2, ignore()], + "first 2 elements are as expected, ignoring 3" + ); + + cmp_deeply( + $object, + noclass({value => 5}), + "object looks ok, not checking it's class" + ); + + cmp_deeply( + \@result, + bag('a', 'b', {key => [1, 2]}), + "array has the 3 things we wanted in some order" + ); + +=head1 DESCRIPTION + +If you don't know anything about automated testing in Perl then you should +probably read about Test::Simple and Test::More before preceding. +Test::Deep uses the Test::Builder framework. + +Test::Deep gives you very flexible ways to check that the result you got is +the result you were expecting. At it's simplest it compares two structures +by going through each level, ensuring that the values match, that arrays and +hashes have the same elements and that references are blessed into the +correct class. It also handles circular data structures without getting +caught in an infinite loop. + +Where it becomes more interesting is in allowing you to do something besides +simple exact comparisons. With strings, the C operator checks that 2 +strings are exactly equal but sometimes that's not what you want. When you +don't know exactly what the string should be but you do know some things +about how it should look, C is no good and you must use pattern matching +instead. Test::Deep provides pattern matching for complex data structures + +Test::Deep has B> of exports. See L below. + +=head1 EXAMPLES + +How Test::Deep works is much easier to understand by seeing some examples. + +=head2 Without Test::Deep + +Say you want to test a function which returns a string. You know that your +string should be a 7 digit number beginning with 0, C is no good in this +situation, you need a regular expression. So you could use Test::More's +C function: + + like($string, qr/^0[0-9]{6}$/, "number looks good"); + +Similarly, to check that a string looks like a name, you could do: + + like($string, qr/^(Mr|Mrs|Miss) \w+ \w+$/, + "got title, first and last name"); + +Now imagine your function produces a hash with some personal details in it. +You want to make sure that there are 2 keys, Name and Phone and that the +name looks like a name and the phone number looks like a phone number. You +could do: + + $hash = make_person(); + like($hash->{Name}, qr/^(Mr|Mrs|Miss) \w+ \w+$/, "name ok"); + like($hash->{Phone}, qr/^0[0-9]{6}$/, "phone ok"); + is(scalar keys %$hash, 2, "correct number of keys"); + +But that's not quite right, what if make_person has a serious problem and +didn't even return a hash? We really need to write + + if (ref($hash) eq "HASH") + { + like($hash->{Name}, qr/^(Mr|Mrs|Miss) \w+ \w+$/, "name ok"); + like($hash->{Phone}, qr/^0[0-9]{6}$/, "phone ok"); + is(scalar keys %$hash, 2, "correct number of keys"); + } + else + { + fail("person not a hash"); + fail("person not a hash"); + fail("person not a hash"); # need 3 to keep the plan correct + } + +Already this is getting messy, now imagine another entry in the hash, an +array of children's names. This would require + + + if (ref($hash) eq "HASH") + { + like($hash->{Name}, $name_pat, "name ok"); + like($hash->{Phone}, '/^0d{6}$/', "phone ok"); + my $cn = $hash->{ChildNames}; + if (ref($cn) eq "ARRAY") + { + foreach my $child (@$cn) + { + like($child, $name_pat); + } + } + else + { + fail("child names not an array") + } + } + else + { + fail("person not a hash"); + } + +This is a horrible mess and because we don't know in advance how many +children's names there will be, we can't make a plan for our test anymore +(actually, we could but it would make things even more complicated). + +Test::Deep to the rescue. + +=head2 With Test::Deep + + my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$'); + cmp_deeply( + $person, + { + Name => $name_re, + Phone => re('^0d{6}$'), + ChildNames => array_each($name_re) + }, + "person ok" + ); + +This will do everything that the messy code above does and it will give a +sensible message telling you exactly what went wrong if it finds a part of +$person that doesn't match the pattern. C and C are +special function imported from Test::Deep. They create a marker that tells +Test::Deep that something different is happening here. Instead of just doing +a simple comparison and checking are two things exactly equal, it should do +something else. + +If a person was asked to check that 2 structures are equal, they could print +them both out and compare them line by line. The markers above are similar +to writing a note in red pen on one of the printouts telling the person that +for this piece of the structure, they should stop doing simple line by line +comparison and do something else. + +C means that Test::Deep should check that the current piece of +data matches the regex in C<$regex>. C means that +Test::Deep should expect the current piece of data to be an array and it +should check that every element of that array matches C<$struct>. +In this case, every element of C<< $person->{ChildNames} >> should look like a +name. If say the 3rd one didn't you would get an error message something +like + + Using Regexp on $data->{ChildNames}[3] + got : 'Queen John Paul Sartre' + expect : /^(Mr|Mrs|Miss) \w+ \w+$/ + +There are lots of other special comparisons available, see +L below for the full list. + +=head2 Reusing structures + +Test::Deep is good for reusing test structures so you can do this + + my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$'); + my $person_cmp = { + Name => $name_re, + Phone => re('^0d{6}$'), + ChildNames => array_each($name_re) + }; + + cmp_deeply($person1, $person_cmp, "person ok"); + cmp_deeply($person2, $person_cmp, "person ok"); + cmp_deeply($person3, $person_cmp, "person ok"); + +You can even put $person_cmp in a module and let other people use it when +they are writing test scripts for modules that use your modules. + +To make things a little more difficult, lets change the person data +structure so that instead of a list of ChildNames, it contains a list of +hashes, one for each child. So in fact our person structure will contain +other person structures which may contain other person structures and so on. +This is easy to handle with Test::Deep because Test::Deep structures can +include themselves. Simply do + + my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$'); + my $person_cmp = { + Name => $name_re, + Phone => re('^0d{6}$'), + # note no mention of Children here + }; + + $person_cmp->{Children} = array_each($person_cmp); + + cmp_deeply($person, $person_cmp, "person ok"); + +This will now check that $person->{Children} is an array and that every +element of that array also matches C<$person_cmp>, this includes checking +that it's children also match the same pattern and so on. + +=head2 Circular data structures + +A circular data structure is one which loops back on itself, you can make +one easily by doing + + my @b; + my @a = (1, 2, 3, \@b); + push(@b, \@a); + +now C<@a> contains a reference to be C<@b> and C<@b> contains a reference to +C<@a>. This causes problems if you have a program that wants to look inside +C<@a> and keep looking deeper and deeper at every level, it could get caught +in an infinite loop looking into C<@a> then C<@b> then C<@a> then C<@b> and +so on. + +Test::Deep avoids this problem so we can extend our example further by +saying that a person should also list their parents. + + my $name_re = re('^(Mr|Mrs|Miss) \w+ \w+$'); + my $person_cmp = { + Name => $name_re, + Phone => re('^0d{6}$'), + # note no mention of Children here + }; + + $person_cmp->{Children} = each_array($person_cmp); + $person_cmp->{Parents} = each_array($person_cmp); + + cmp_deeply($person, $person_cmp, "person ok"); + +So this will check that for each child C<$child> in C<< $person->{Children} >> +that the C<< $child->{Parents} >> matches C<$person_cmp> however it is smart +enough not to get caught in an infinite loop where it keeps bouncing between +the same Parent and Child. + +=head1 TERMINOLOGY + +C takes 3 arguments. C<$got> is the +structure that you are checking, you must not include any special +comparisons in this structure or you will get a fatal error. C<$expected> +describes what Test::Deep will be looking for in $got. You can put special +comparisons in $expected if you want to. + +As Test::Deep descends through the 2 structures, it compares them one piece +at a time, so at any point in the process, Test::Deep is thinking about 2 +things - the current value from C<$got> and the current value from +C<$expected>. In the documentation, I call them C<$got_v> and C +respectively. + +=head1 COMPARISON FUNCTIONS + +=head3 cmp_deeply + + my $ok = cmp_deeply($got, $expected, $name) + +C<$got> is the result to be checked. C<$expected> is the structure against +which C<$got> will be check. C<$name> is the test name. + +This is the main comparison function, the others are just wrappers around +this. C<$got> and C<$expected> are compared recursively. Each value in +C<$expected> defines what's expected at the corresponding location in C<$got>. +Simple scalars are compared with C. References to structures like hashes +and arrays are compared recursively. + +Items in C<$expected>, though, can also represent complex tests that check for +numbers in a given range, hashes with at least a certain set of keys, a string +matching a regex, or many other things. + +See L for details. + +=head3 cmp_bag + + my $ok = cmp_bag(\@got, \@bag, $name) + +Is shorthand for cmp_deeply(\@got, bag(@bag), $name) + +I: Both arguments must be array refs. If they aren't an exception will be +thrown. + +=head3 cmp_set + + my $ok = cmp_set(\@got, \@set, $name) + +Is shorthand for cmp_deeply(\@got, set(@set), $name) + +=head3 cmp_methods + + my $ok = cmp_methods(\@got, \@methods, $name) + +Is shorthand for cmp_deeply(\@got, methods(@methods), $name) + +=head3 eq_deeply + + my $ok = eq_deeply($got, $expected) + +This is the same as cmp_deeply() except it just returns true or +false. It does not create diagnostics or talk to L, but +if you want to use it in a non-testing environment then you should +import it through L. For example + + use Test::Deep::NoTest; + print "a equals b" unless eq_deeply($a, $b); + +otherwise the L framework will be loaded and testing messages +will be output when your program ends. + +=head3 cmp_details + + ($ok, $stack) = cmp_details($got, $expected) + +This behaves much like eq_deeply, but it additionally allows you to +produce diagnostics in case of failure by passing the value in C<$stack> +to C. + +Do not make assumptions about the structure or content of C<$stack> and +do not use it if C<$ok> contains a true value. + +See L for example uses. + +=head1 SPECIAL COMPARISONS PROVIDED + +In the documentation below, C<$got_v> is used to indicate any given value +within the C<$got> structure. + +=head3 ignore + + cmp_deeply( $got, ignore() ); + +This makes Test::Deep skip tests on C<$got_v>. No matter what value C<$got_v> +has, Test::Deep will think it's correct. This is useful if some part of the +structure you are testing is very complicated and already tested elsewhere, +or if it is unpredictable. + + cmp_deeply( + $got, + { + name => 'John', + rando m => ignore(), + address => [ '5 A street', 'a town', 'a country' ], + } + ); + +is the equivalent of checking + + $got->{name} eq 'John'; + exists $got->{random}; + cmp_deeply($got->{address}, ['5 A street', 'a town', 'a country']); + +=head3 methods + + cmp_deeply( $got, methods(%hash) ); + +%hash is a hash of method call => expected value pairs. + +This lets you call methods on an object and check the result of each call. +The methods will be called in the order supplied. If you want to pass +arguments to the method you should wrap the method name and arguments in an +array reference. + + cmp_deeply( + $obj, + methods(name => "John", ["favourite", "food"] => "taco") + ); + +is roughly the equivalent of checking that + + $obj->name eq "John" + $obj->favourite("food") eq "taco" + +The methods will be called in the order you supply them and will be called +in scalar context. If you need to test methods called in list context then +you should use C. + +B Just as in a normal test script, you need to be careful if the +methods you call have side effects like changing the object or other objects +in the structure. Although the order of the methods is fixed, the order of +some other tests is not so if C<$expected> is + + { + manager => methods(@manager_methods), + coder => methods(@coder_methods) + } + +there is no way to know which if manager and coder will be tested first. If +the methods you are testing depend on and alter global variables or if +manager and coder are the same object then you may run into problems. + +=head3 listmethods + + cmp_deeply( $got, listmethods(%hash) ); + +C<%hash> is a hash of pairs mapping method names to expected return values. + +This is almost identical to methods() except the methods are called in list +context instead of scalar context. This means that the expected return +values supplied must be in array references. + + cmp_deeply( + $obj, + listmethods( + name => "John", + ["favourites", "food"] => ["Mapo tofu", "Gongbao chicken"] + ) + ); + +is the equivalent of checking that + + $obj->name eq "John" + cmp_deeply([$obj->favourites("food")], ["Mapo tofu", "Gongbao chicken"]); + +The methods will be called in the order you supply them. + +B The same caveats apply as for methods(). + +=head3 shallow + + cmp_deeply( $got, shallow($thing) ); + +$thing is a ref. + +This prevents Test::Deep from looking inside $thing. It allows you to +check that C<$got_v> and C<$thing> are references to the same variable. So + + my @a = @b = (1, 2, 3); + cmp_deeply(\@a, \@b); + +will pass because C<@a> and C<@b> have the same elements however + + cmp_deeply(\@a, shallow(\@b)) + +will fail because although C<\@a> and C<\@b> both contain C<1, 2, 3> they are +references to different arrays. + +=head3 noclass + + cmp_deeply( $got, noclass($thing) ); + +$thing is a structure to be compared against. + +This makes Test::Deep ignore the class of objects, so it just looks at the +data they contain. Class checking will be turned off until Test::Deep is +finished comparing C<$got_v> against C<$thing>. Once Test::Deep comes out of +C<$thing> it will go back to it's previous setting for checking class. + +This can be useful when you want to check that objects have been +constructed correctly but you don't want to write lots of +Ces. If C<@people> is an array of Person objects then + + cmp_deeply(\@people, [ + bless {name => 'John', phone => '555-5555'}, "Person", + bless {name => 'Anne', phone => '444-4444'}, "Person", + ]); + +can be replaced with + + cmp_deeply(\@people, noclass([ + {name => 'John', phone => '555-5555'}, + {name => 'Anne', phone => '444-4444'} + ])); + +However, this is testing so you should also check that the objects are +blessed correctly. You could use a map to bless all those hashes or you +could do a second test like + + cmp_deeply(\@people, array_each(isa("Person")); + +=head3 useclass + + cmp_deeply( $got, useclass($thing) ); + +This turns back on the class comparison while inside a C. + + cmp_deeply( + $got, + noclass( + [ + useclass( $object ) + ] + ) + ) + +In this example the class of the array reference in C<$got> is ignored but +the class of C<$object> is checked, as is the class of everything inside +C<$object>. + +=head3 re + + cmp_deeply( $got, re($regexp, $capture_data, $flags) ); + +C<$regexp> is either a regular expression reference produced with C +or a string which will be used to construct a regular expression. + +C<$capture_data> is optional and is used to check the strings captured by an +regex. This should can be an array ref or a Test::Deep comparator that works +on array refs. + +C<$flags> is an optional string which controls whether the regex runs as a +global match. If C<$flags> is "g" then the regex will run as C. + +Without C<$capture_data>, this simply compares C<$got_v> with the regular +expression provided. So + + cmp_deeply($got, [ re("ferg") ]) + +is the equivalent of + + $got->[0] =~ /ferg/ + +With C<$capture_data>, + + cmp_deeply($got, [re($regex, $capture_data)]) + +is the equivalent of + + my @data = $got->[0] =~ /$regex/; + cmp_deeply(\@data, $capture_data); + +So you can do something simple like + + cmp_deeply($got, re(qr/(\d\d)(\w\w)/, [25, "ab" ])) + +to check that C<(\d\d)> was 25 and C<(\w\w)> was "ab" but you can also use +Test::Deep objects to do more complex testing of the captured values + + cmp_deeply( + "cat=2,dog=67,sheep=3,goat=2,dog=5", + re( + qr/(\D+)=\d+,?/, + set(qw( cat sheep dog )), + "g" + ), + ); + +here, the regex will match the string and will capture the animal names and +check that they match the specified set, in this case it will fail, +complaining that "goat" is not in the set. + +=head3 all + + cmp_deeply( $got, all(@expecteds) ); + +C<@expecteds> is an array of expected structures. + +This allows you to compare data against multiple expected results and make +sure each of them matches. + + cmp_deeply($got, all(isa("Person"), methods(name => 'John'))) + +is equivalent to + + $got->isa("Person") + $got->name eq 'John' + +If either test fails then the whole thing is considered a fail. This is a +short-circuit test, the testing is stopped after the first failure, although +in the future it may complete all tests so that diagnostics can be output +for all failures. When reporting failure, the parts are counted from 1. + +Thanks to the magic of overloading, you can write + + any( re("^wi"), all(isa("Person"), methods(name => 'John')) ) + +as + + re("^wi") | isa("Person") & methods(name => 'John') + +Note B C<|> not double, as C<||> cannot be overloaded. This will +only work when there is a special comparison involved. If you write + + "john" | "anne" | "robert" + +Perl will turn this into + + "{onort" + +which is presumably not what you wanted. This is because perl ors them +together as strings before Test::Deep gets a chance to do any overload +tricks. + +=head3 any + + cmp_deeply( $got, any(@expecteds) ); + +C<@expecteds> is an array of expected structures. + +This can be used to compare data against multiple expected results and make +sure that at least one of them matches. This is a short-circuit test so if +a test passes then none of the tests after that will be attempted. + +You can also use overloading with C<|> similarly to all(). + +=head3 Isa + + cmp_deeply( $got, Isa($class) ); + +=head3 isa + + cmp_deeply( $got, isa($class) ); + +C<$class> is a class name. + +This uses C to check that C<$got_v> is blessed into the +class C<$class>. + +B C does exactly as documented here, but C is slightly +different. If C is called with 1 argument it falls through to +C. If C called with 2 arguments, it falls through to +C. This is to prevent breakage when you import C into +a package that is used as a class. Without this, anyone calling +Cisa($other_class)> would get the wrong answer. This is a hack +to patch over the fact that C is exported by default. + +=head3 obj_isa + + cmp_deeply( $got, obj_isa($class) ); + +This test accepts only objects that are instances of C<$class> or a subclass. +Unlike the C test, this test will never accept class names. + +=head3 array_each + + cmp_deeply( \@got, array_each($thing) ); + +C<$thing> is a structure to be compared against. + +<$got_v> must be an array reference. Each element of it will be compared to +$thing. This is useful when you have an array of similar things, for example +objects of a known type and you don't want to have to repeat the same test +for each one. + + my $common_tests = all( + isa("MyFile"), + methods( + handle => isa("IO::Handle") + filename => re("^/home/ted/tmp"), + ) + ); + + cmp_deeply($got, array_each($common_tests)); + +is similar to + + foreach my $got_v (@$got) { + cmp_deeply($got_v, $common_tests) + } + +Except it will not explode if C<$got> is not an array reference. It will +check that each of the objects in C<@$got> is a MyFile and that each one +gives the correct results for it's methods. + +You could go further, if for example there were 3 files and you knew the +size of each one you could do this + + cmp_deeply( + $got, + all( + array_each($common_tests), + [ + methods(size => 1000), + methods(size => 200), + methods(size => 20) + ] + ) + ) + cmp_deeply($got, array_each($structure)); + +=head3 hash_each + + cmp_deeply( \%got, hash_each($thing) ); + +This test behaves like C (see above) but tests that each hash +value passes its tests. + +=head3 str + + cmp_deeply( $got, str($string) ); + +$string is a string. + +This will stringify C<$got_v> and compare it to C<$string> using C, even +if C<$got_v> is a ref. It is useful for checking the stringified value of an +overloaded reference. + +=head3 num + + cmp_deeply( $got, num($number, $tolerance) ); + +C<$number> is a number. + +C<$tolerance> is an optional number. + +This will add 0 to C<$got_v> and check if it's numerically equal to +C<$number>, even if C<$got_v> is a ref. It is useful for checking the +numerical value of an overloaded reference. If C<$tolerance> is supplied +then this will check that C<$got_v> and C<$exp_v> are less than +C<$tolerance> apart. This is useful when comparing floating point numbers as +rounding errors can make it hard or impossible for C<$got_v> to be exactly +equal to C<$exp_v>. When C<$tolerance> is supplied, the test passes if +C. + +B in Perl, C<"12blah" == 12> because Perl will be smart and convert +"12blah" into 12. You may not want this. There was a strict mode but that is +now gone. A "looks like a number" test will replace it soon. Until then you +can usually just use the string() comparison to be more strict. This will +work fine for almost all situations, however it will not work when <$got_v> +is an overloaded value who's string and numerical values differ. + +=head3 bool + + cmp_deeply( $got, bool($value) ); + +C<$value> is anything you like but it's probably best to use 0 or 1 + +This will check that C<$got_v> and C<$value> have the same truth value, that +is they will give the same result when used in boolean context, like in an +C statement. + +=head3 code + + cmp_deeply( $got, code(\&subref) ); + +C<\&subref> is a reference to a subroutine which will be passed a single +argument, it then should return a true or false and possibly a string + +This will pass C<$got_v> to the subroutine which returns true or false to +indicate a pass or fail. Fails can be accompanied by a diagnostic string +which gives an explanation of why it's a fail. + + sub check_name + { + my $name = shift; + if ($boss->likes($name)) + { + return 1; + } + else + { + return (0, "the boss doesn't like your name"); + } + } + + cmp_deeply("Brian", code(\&check_name)); + +=head2 SET COMPARISONS + +Set comparisons give special semantics to array comparisons: + +=over 4 + +=item * The order of items in a set is irrelevant + +=item * The presence of duplicate items in a set is ignored. + +=back + +As such, in any set comparison, the following arrays are equal: + + [ 1, 2 ] + [ 1, 1, 2 ] + [ 1, 2, 1 ] + [ 2, 1, 1 ] + [ 1, 1, 2 ] + +All are interpreted by C semantics as if the set was only specified as: + + [ 1, 2 ] + +All C functions return an object which can have additional items added to +it: + + my $set = set( 1, 2 ); + $set->add(1, 3, 1 ); # Set is now ( 1, 2, 3 ) + +Special care must be taken when using special comparisons within sets. See +L for details. + +=head3 set + + cmp_deeply( \@got, set(@elements) ); + +This does a set comparison, that is, it compares two arrays but ignores the +order of the elements and it ignores duplicate elements, but ensures that all +items in in C<@elements> will be in C<$got> and all items in C<$got> will be +in C<@elements>. + +So the following tests will be passes, and will be equivalent: + + cmp_deeply([1, 2, 2, 3], set(3, 2, 1, 1)); + cmp_deeply([1, 2, 3], set(3, 2, 1)); + +=head3 supersetof + + cmp_deeply( \@got, supersetof(@elements) ); + +This function works much like L<< C|/set >>, and performs a set comparison +of C<$got_v> with the elements of C<@elements>. + +C is however slightly relaxed, such that C<$got> may contain things +not in C<@elements>, but must at least contain all C<@elements>. + +These two statements are equivalent, and will be passes: + + cmp_deeply([1,2,3,3,4,5], supersetof(2,2,3)); + cmp_deeply([1,2,3,4,5], supersetof(2,3)); + +But these will be failures: + + cmp_deeply([1,2,3,4,5], supersetof(2,3,6)); # 6 not in superset + cmp_deeply([1], supersetof(1,2)); # 2 not in superset + +=head3 subsetof + + cmp_deeply( \@got, subsetof(@elements) ); + +This function works much like L<< C|/set >>, and performs a set comparison +of C<$got_v> with the elements of C<@elements>. + +This is the inverse of C, which expects all unique elements found +in C<$got_v> must be in C<@elements>. + + cmp_deeply([1,2,4,5], subsetof(2,3,3) ) # Fail: 1,4 & 5 extra + cmp_deeply([2,3,3], subsetof(1,2,4,5) ) # Fail: 3 extra + cmp_deeply([2,3,3], subsetof(1,2,4,5,3)) # Pass + +=head3 noneof + + cmp_deeply( \@got, noneof(@elements) ); + +@elements is an array of elements, wherein no elements in C<@elements> may be +found in C<$got_v>. + +For example: + + # Got has no 1, no 2, and no 3 + cmp_deeply( [1], noneof( 1, 2, 3 ) ); # fail + cmp_deeply( [5], noneof( 1, 2, 3 ) ); # pass + +=head2 BAG COMPARISONS + +Bag comparisons give special semantics to array comparisons, that are similar +to L<< set comparisons|/SET COMPARISONS >>, but slightly different. + +=over 4 + +=item * The order of items in a bag is irrelevant + +=item * The presence of duplicate items in a bag is B + +=back + +As such, in any bag comparison, the following arrays are equal: + + [ 1, 1, 2 ] + [ 1, 2, 1 ] + [ 2, 1, 1 ] + [ 1, 1, 2 ] + +However, they are B equal to any of the following: + + [ 1, 2 ] + [ 1, 2, 2 ] + [ 1, 1, 1, 2 ] + +All C functions return an object which can have additional items added to +it: + + my $bag = bag( 1, 2 ); + $bag->add(1, 3, 1 ); # Bag is now ( 1, 1, 1, 2, 3 ) + +Special care must be taken when using special comparisons within bags. See +L for details. + +=head3 bag + + cmp_deeply( \@got, bag(@elements) ); + +This does an order-insensitive bag comparison between C<$got> and +C<@elements>, ensuring that: + +=over 4 + +=item each item in C<@elements> is found in C<$got> + +=item the number of times a C<$expected_v> is found in C<@elements> is +reflected in C<$got> + +=item no items are found in C<$got> other than those in C<@elements>. + +=back + +As such, the following are passes, and are equivalent to each other: + + cmp_deeply([1, 2, 2], bag(2, 2, 1)) + cmp_deeply([2, 1, 2], bag(2, 2, 1)) + cmp_deeply([2, 2, 1], bag(2, 2, 1)) + +But the following are failures: + + cmp_deeply([1, 2, 2], bag(2, 2, 1, 1)) # Not enough 1's in Got + cmp_deeply([1, 2, 2, 1], bag(2, 2, 1) ) # Too many 1's in Got + +=head3 superbagof + + cmp_deeply( \@got, superbagof( @elements ) ); + +This function works much like L<< C|/bag >>, and performs a bag comparison +of C<$got_v> with the elements of C<@elements>. + +C is however slightly relaxed, such that C<$got> may contain things +not in C<@elements>, but must at least contain all C<@elements>. + +So: + + # pass + cmp_deeply( [1, 1, 2], superbagof( 1 ) ); + + # fail: not enough 1's in superbag + cmp_deeply( [1, 1, 2], superbagof( 1, 1, 1 )); + +=head3 subbagof + + cmp_deeply( \@got, subbagof(@elements) ); + +This function works much like L<< C|/bag >>, and performs a bag comparison +of C<$got_v> with the elements of C<@elements>. + +This is the inverse of C, and expects all elements in C<$got> to +be in C<@elements>, while allowing items to exist in C<@elements> that are not +in C<$got> + + # pass + cmp_deeply( [1], subbagof( 1, 1, 2 ) ); + + # fail: too many 1's in subbag + cmp_deeply( [1, 1, 1], subbagof( 1, 1, 2 ) ); + +=head2 HASH COMPARISONS + +Typically, if you're doing simple hash comparisons, + + cmp_deeply( \%got, \%expected ) + +is sufficient. C will ensure C<%got> and C<%hash> have identical +keys, and each key from either has the same corresponding value. + +=head3 superhashof + + cmp_deeply( \%got, superhashof(\%hash) ); + +This will check that the hash C<%$got> is a "super-hash" of C<%hash>. That +is that all the key and value pairs in C<%hash> appear in C<%$got> but +C<%$got> can have extra ones also. + +For example + + cmp_deeply({a => 1, b => 2}, superhashof({a => 1})) + +will pass but + + cmp_deeply({a => 1, b => 2}, superhashof({a => 1, c => 3})) + +will fail. + +=head3 subhashof + + cmp_deeply( \%got, subhashof(\%hash) ); + +This will check that the hash C<%$got> is a "sub-hash" of C<%hash>. That is +that all the key and value pairs in C<%$got> also appear in C<%hash>. + +For example + + cmp_deeply({a => 1}, subhashof({a => 1, b => 2})) + +will pass but + + cmp_deeply({a => 1, c => 3}, subhashof({a => 1, b => 2})) + +will fail. + +=head1 DIAGNOSTIC FUNCTIONS + +=head3 deep_diag + + my $reason = deep_diag($stack); + +C<$stack> is a value returned by cmp_details. Do not call this function +if cmp_details returned a true value for C<$ok>. + +C returns a human readable string describing how the +comparison failed. + +=head1 ANOTHER EXAMPLE + +You've written a module to handle people and their film interests. Say you +have a function that returns an array of people from a query, each person is +a hash with 2 keys: Name and Age and the array is sorted by Name. You can do + + cmp_deeply( + $result, + [ + {Name => 'Anne', Age => 26}, + {Name => "Bill", Age => 47} + {Name => 'John', Age => 25}, + ] + ); + +Soon after, your query function changes and all the results now have an ID +field. Now your test is failing again because you left out ID from each of +the hashes. The problem is that the IDs are generated by the database and +you have no way of knowing what each person's ID is. With Test::Deep you can +change your query to + + cmp_deeply( + $result, + [ + {Name => 'John', Age => 25, ID => ignore()}, + {Name => 'Anne', Age => 26, ID => ignore()}, + {Name => "Bill", Age => 47, ID => ignore()} + ] + ); + +But your test still fails. Now, because you're using a database, you no +longer know what order the people will appear in. You could add a sort into +the database query but that could slow down your application. Instead you +can get Test::Deep to ignore the order of the array by doing a bag +comparison instead. + + cmp_deeply( + $result, + bag( + {Name => 'John', Age => 25, ID => ignore()}, + {Name => 'Anne', Age => 26, ID => ignore()}, + {Name => "Bill", Age => 47, ID => ignore()} + ) + ); + +Finally person gets even more complicated and includes a new field called +Movies, this is a list of movies that the person has seen recently, again +these movies could also come back in any order so we need a bag inside our +other bag comparison, giving us something like + + cmp_deeply( + $result, + bag( + {Name => 'John', Age => 25, ID => ignore(), Movies => bag(...)}, + {Name => 'Anne', Age => 26, ID => ignore(), Movies => bag(...)}, + {Name => "Bill", Age => 47, ID => ignore(), Movies => bag(...)} + ) + ); + +=head1 USING TEST::DEEP WITH TEST::BUILDER + +Combining C and C makes it possible to use +Test::Deep in your own test classes. + +In a L subclass, create a test method in the following +form: + + sub behaves_ok { + my $self = shift; + my $expected = shift; + my $test_name = shift; + + my $got = do_the_important_work_here(); + + my ($ok, $stack) = cmp_details($got, $expected); + unless ($Test->ok($ok, $test_name)) { + my $diag = deep_diag($stack); + $Test->diag($diag); + } + } + +As the subclass defines a test class, not tests themselves, make sure it +uses L, not C itself. + +=head1 LIMITATIONS + +Currently any CODE, GLOB or IO refs will be compared using shallow(), which +means only their memory addresses are compared. + +=head1 BUGS + +There is a bug in set and bag compare to do with competing SCs. It only +occurs when you put certain special comparisons inside bag or set +comparisons you don't need to worry about it. The full details are in the +C docs. It will be fixed in an upcoming version. + +=head1 CAVEATS + +=head2 SPECIAL CARE WITH SPECIAL COMPARISONS IN SETS AND BAGS + +If you use certain special comparisons within a bag or set comparison there is +a danger that a test will fail when it should have passed. It can only happen +if two or more special comparisons in the bag are competing to match elements. +Consider this comparison + + cmp_deeply(['furry', 'furball'], bag(re("^fur"), re("furb"))) + +There are two things that could happen, hopefully C is paired with +"furry" and C is paired with "furb" and everything is fine but it +could happen that C is paired with "furball" and then C +cannot find a match and so the test fails. Examples of other competing +comparisons are C vs C and +C<< methods(m1 => "v1", m2 => "v2") >> vs C<< methods(m1 => "v1") >> + +This problem is could be solved by using a slower and more complicated +algorithm for set and bag matching. Something for the future... + +=head1 WHAT ARE SPECIAL COMPARISONS? + +A special comparison (SC) is simply an object that inherits from +Test::Deep::Cmp. Whenever C<$expected_v> is an SC then instead of checking +C<$got_v eq $expected_v>, we pass control over to the SC and let it do it's +thing. + +Test::Deep exports lots of SC constructors, to make it easy for you to use +them in your test scripts. For example is C is just a handy way +of creating a Test::Deep::Regexp object that will match any string containing +"hello". So + + cmp_deeply([ 'a', 'b', 'hello world'], ['a', 'b', re("^hello")]); + +will check C<'a' eq 'a'>, C<'b' eq 'b'> but when it comes to comparing +C<'hello world'> and C it will see that +$expected_v is an SC and so will pass control to the Test::Deep::Regexp class +by do something like C<< $expected_v->descend($got_v) >>. The C +method should just return true or false. + +This gives you enough to write your own SCs but I haven't documented how +diagnostics works because it's about to get an overhaul. + +=head1 EXPORTS + +By default, Test::Deep will export everything in its C tag, as if you had +written: + + use Test::Deep ':v0'; + +Those things are: + + all any array array_each arrayelementsonly arraylength arraylengthonly bag + blessed bool cmp_bag cmp_deeply cmp_methods cmp_set code eq_deeply hash + hash_each hashkeys hashkeysonly ignore Isa isa listmethods methods noclass + none noneof num obj_isa re reftype regexpmatches regexponly regexpref + regexprefonly scalarrefonly scalref set shallow str subbagof subhashof + subsetof superbagof superhashof supersetof useclass + +A slightly better set of exports is the C set. It's all the same things, +with the exception of C and C. If you want to import +"everything", you probably want to C<< use Test::Deep ':V1'; >>. + +There's another magic export group: C<:preload>. If that is specified, all of +the Test::Deep plugins will be loaded immediately instead of lazily. + +=head1 SEE ALSO + +L + +=head1 MAINTAINER + + Ricardo Signes + +=head1 AUTHOR + +Fergal Daly Efergal@esatclear.ieE, with thanks to Michael G Schwern +for Test::More's is_deeply function which inspired this. + +B do not bother Fergal Daly with bug reports. Send them to the +maintainer (above) or submit them at L. + +=head1 COPYRIGHT + +Copyright 2003, 2004 by Fergal Daly Efergal@esatclear.ieE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/lib/Test/Deep/All.pm b/lib/Test/Deep/All.pm new file mode 100644 index 0000000..f982c11 --- /dev/null +++ b/lib/Test/Deep/All.pm @@ -0,0 +1,54 @@ +use strict; +use warnings; + +package Test::Deep::All; + +use Scalar::Util (); +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my @list = map { + (Scalar::Util::blessed($_) && $_->isa('Test::Deep::All')) + ? @{ $_->{val} } + : $_ + } @_; + + $self->{val} = \@list; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $data = $self->data; + + my $index = 1; + + foreach my $cmp (@{$self->{val}}) + { + $data->{index} = $index; + $index++; + + next if Test::Deep::descend($got, $cmp); + return 0 + } + + return 1; +} + +sub render_stack +{ + my $self = shift; + my $var = shift; + my $data = shift; + + my $max = @{$self->{val}}; + + return "(Part $data->{index} of $max in $var)"; +} + +1; diff --git a/lib/Test/Deep/Any.pm b/lib/Test/Deep/Any.pm new file mode 100644 index 0000000..2f0eb8f --- /dev/null +++ b/lib/Test/Deep/Any.pm @@ -0,0 +1,63 @@ +use strict; +use warnings; + +package Test::Deep::Any; + +use Scalar::Util (); +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my @list = map { + (Scalar::Util::blessed($_) && $_->isa('Test::Deep::Any')) + ? @{ $_->{val} } + : $_ + } @_; + + $self->{val} = \@list; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + foreach my $cmp (@{$self->{val}}) + { + return 1 if Test::Deep::eq_deeply_cache($got, $cmp); + } + + return 0; +} + +sub renderExp +{ + my $self = shift; + + my @expect = map {; Test::Deep::wrap($_) } @{ $self->{val} }; + my $things = join(", ", map {$_->renderExp} @expect); + + return "Any of ( $things )"; +} + +sub diagnostics +{ + my $self = shift; + my ($where, $last) = @_; + + my $got = $self->renderGot($last->{got}); + my $exp = $self->renderExp; + + my $diag = <{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + return 0 unless Test::Deep::descend($got, Test::Deep::arraylength(scalar @$exp)); + + return 0 unless $self->test_class($got); + + return Test::Deep::descend($got, Test::Deep::arrayelementsonly($exp)); +} + +sub reset_arrow +{ + return 0; +} + +1; diff --git a/lib/Test/Deep/ArrayEach.pm b/lib/Test/Deep/ArrayEach.pm new file mode 100644 index 0000000..cba68ac --- /dev/null +++ b/lib/Test/Deep/ArrayEach.pm @@ -0,0 +1,37 @@ +use strict; +use warnings; + +package Test::Deep::ArrayEach; + +use Test::Deep::Cmp; +use Scalar::Util (); + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + return unless ref $got && Scalar::Util::reftype($got) eq 'ARRAY'; + my $exp = [ ($self->{val}) x @$got ]; + + return Test::Deep::descend($got, $exp); +} + +sub renderExp +{ + my $self = shift; + my $exp = shift; + + return '[ ' . $self->SUPER::renderExp($self->{val}) . ', ... ]'; +} + +1; diff --git a/lib/Test/Deep/ArrayElementsOnly.pm b/lib/Test/Deep/ArrayElementsOnly.pm new file mode 100644 index 0000000..4b8aa44 --- /dev/null +++ b/lib/Test/Deep/ArrayElementsOnly.pm @@ -0,0 +1,54 @@ +use strict; +use warnings; + +package Test::Deep::ArrayElementsOnly; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + my $data = $self->data; + + for my $i (0..$#{$exp}) + { + $data->{index} = $i; + + my $got_elem = $got->[$i]; + my $exp_elem = $exp->[$i]; + + return 0 unless Test::Deep::descend($got_elem, $exp_elem) + } + + return 1; +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + $var .= "->" unless $Test::Deep::Stack->incArrow; + $var .= "[$data->{index}]"; + + return $var; +} + +sub reset_arrow +{ + return 0; +} + +1; diff --git a/lib/Test/Deep/ArrayLength.pm b/lib/Test/Deep/ArrayLength.pm new file mode 100644 index 0000000..8a8aab4 --- /dev/null +++ b/lib/Test/Deep/ArrayLength.pm @@ -0,0 +1,29 @@ +use strict; +use warnings; + +package Test::Deep::ArrayLength; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + return 0 unless $self->test_reftype($got, "ARRAY"); + + return Test::Deep::descend($got, Test::Deep::arraylengthonly($exp)); +} + +1; diff --git a/lib/Test/Deep/ArrayLengthOnly.pm b/lib/Test/Deep/ArrayLengthOnly.pm new file mode 100644 index 0000000..ecdb6ef --- /dev/null +++ b/lib/Test/Deep/ArrayLengthOnly.pm @@ -0,0 +1,60 @@ +use strict; +use warnings; + +package Test::Deep::ArrayLengthOnly; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $len = $self->{val}; + + return @$got == $len; +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + + return "array length of $var"; +} + +sub renderVal +{ + my $self = shift; + + my $val = shift; + + return "array with $val element(s)" +} + +sub renderGot +{ + my $self = shift; + + my $got = shift; + + return $self->renderVal(@$got + 0); +} + +sub renderExp +{ + my $self = shift; + + return $self->renderVal($self->{val}); +} + +1; diff --git a/lib/Test/Deep/Blessed.pm b/lib/Test/Deep/Blessed.pm new file mode 100644 index 0000000..88553c9 --- /dev/null +++ b/lib/Test/Deep/Blessed.pm @@ -0,0 +1,47 @@ +use strict; +use warnings; + +package Test::Deep::Blessed; + +use Test::Deep::Cmp; + +use Scalar::Util qw( blessed ); + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + my $blessed = blessed($got); + + return Test::Deep::descend($blessed, Test::Deep::shallow($exp)); +} + +sub render_stack +{ + my $self = shift; + my $var = shift; + + return "blessed($var)" +} + +sub renderGot +{ + my $self = shift; + + my $got = shift; + + $self->SUPER::renderGot(blessed($got)); +} + +1; diff --git a/lib/Test/Deep/Boolean.pm b/lib/Test/Deep/Boolean.pm new file mode 100644 index 0000000..4860fe9 --- /dev/null +++ b/lib/Test/Deep/Boolean.pm @@ -0,0 +1,46 @@ +use strict; +use warnings; + +package Test::Deep::Boolean; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + $self->{val} = shift() ? 1 : 0; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + return !( $got xor $self->{val} ); +} + +sub diag_message +{ + my $self = shift; + my $where = shift; + return "Comparing $where as a boolean"; +} + +sub renderExp +{ + my $self = shift; + + $self->renderGot($self->{val}); +} + +sub renderGot +{ + my $self = shift; + + my $val = shift; + + return ($val ? "true" : "false")." (".Test::Deep::render_val($val).")"; +} + +1; diff --git a/lib/Test/Deep/Cache.pm b/lib/Test/Deep/Cache.pm new file mode 100644 index 0000000..8cda6f8 --- /dev/null +++ b/lib/Test/Deep/Cache.pm @@ -0,0 +1,78 @@ +use strict; +use warnings; + +package Test::Deep::Cache; + +use Test::Deep::Cache::Simple; + +sub new +{ + my $pkg = shift; + + my $self = bless {}, $pkg; + + $self->{expects} = [Test::Deep::Cache::Simple->new]; + $self->{normal} = [Test::Deep::Cache::Simple->new]; + + $self->local; + + return $self; +} + +sub add +{ + my $self = shift; + + my $type = $self->type; + + $self->{$type}->[-1]->add(@_); +} + +sub cmp +{ + # go through all the caches to see if we know this one + + my $self = shift; + + my $type = $self->type; + + foreach my $cache (@{$self->{$type}}) + { + return 1 if $cache->cmp(@_); + } + + return 0 +} + +sub local +{ + my $self = shift; + + foreach my $type (qw( expects normal )) + { + push(@{$self->{$type}}, Test::Deep::Cache::Simple->new); + } +} + +sub finish +{ + my $self = shift; + + my $keep = shift; + + foreach my $type (qw( expects normal )) + { + my $caches = $self->{$type}; + + my $last = pop @$caches; + + $caches->[-1]->absorb($last) if $keep; + } +} + +sub type +{ + return $Test::Deep::Expects ? "expects" : "normal"; +} + +1; diff --git a/lib/Test/Deep/Cache/Simple.pm b/lib/Test/Deep/Cache/Simple.pm new file mode 100644 index 0000000..1d8aeb3 --- /dev/null +++ b/lib/Test/Deep/Cache/Simple.pm @@ -0,0 +1,83 @@ +use strict; +use warnings; + +package Test::Deep::Cache::Simple; +use Carp qw( confess ); + +use Scalar::Util qw( refaddr ); + +BEGIN +{ + if (grep /^weaken$/, @Scalar::Util::EXPORT_FAIL) + { + # we're running on a version of perl that has no weak refs, so we + # just install a no-op sub for weaken instead of importing it + *weaken = sub {}; + } + else + { + Scalar::Util->import('weaken'); + } +} + +sub new +{ + my $pkg = shift; + + my $self = bless {}, $pkg; + + return $self; +} + +sub add +{ + my $self = shift; + + my ($d1, $d2) = @_; + { + local $SIG{__DIE__}; + + local $@; + + # cannot weaken read only refs, no harm if we can't as they never + # disappear + eval{weaken($d1)}; + eval{weaken($d2)}; + } + + $self->{fn_get_key(@_)} = [$d1, $d2]; +} + +sub cmp +{ + my $self = shift; + + my $key = fn_get_key(@_); + my $pair = $self->{$key}; + + # are both weakened refs still valid, if not delete this entry + if (ref($pair->[0]) and ref($pair->[1])) + { + return 1; + } + else + { + delete $self->{$key}; + return 0; + } +} + +sub absorb +{ + my $self = shift; + + my $other = shift; + + @{$self}{keys %$other} = values %$other; +} + +sub fn_get_key +{ + return join(",", sort (map {refaddr($_)} @_)); +} +1; diff --git a/lib/Test/Deep/Class.pm b/lib/Test/Deep/Class.pm new file mode 100644 index 0000000..7fefda2 --- /dev/null +++ b/lib/Test/Deep/Class.pm @@ -0,0 +1,29 @@ +use strict; +use warnings; + +package Test::Deep::Class; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $snobby = shift; + my $val = shift; + + $self->{snobby} = $snobby; + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + local $Test::Deep::Snobby = $self->{snobby}; + + Test::Deep::wrap($self->{val})->descend($got); +} + +1; diff --git a/lib/Test/Deep/Cmp.pm b/lib/Test/Deep/Cmp.pm new file mode 100644 index 0000000..c663507 --- /dev/null +++ b/lib/Test/Deep/Cmp.pm @@ -0,0 +1,106 @@ +use strict; +use warnings; + +package Test::Deep::Cmp; + +use overload + '&' => \&make_all, + '|' => \&make_any, + '""' => \&string, + fallback => 1, +; + +use Scalar::Util (); + +sub import +{ + my $pkg = shift; + + my $callpkg = caller(); + if ($callpkg =~ /^Test::Deep::/) + { + no strict 'refs'; + + push @{$callpkg."::ISA"}, $pkg; + } +} + +sub new +{ + my $pkg = shift; + + my $self = bless {}, $pkg; + + $self->init(@_); + return $self; +} + +sub init +{ +} + +sub make_all +{ + my ($e1, $e2) = @_; + + return Test::Deep::all($e1, $e2); +} + +sub make_any +{ + my ($e1, $e2) = @_; + + return Test::Deep::any($e1, $e2); +} + +sub cmp +{ + my ($a1, $a2, $rev) = @_; + + ($a1, $a2) = ($a2, $a1) if $rev; + + return (overload::StrVal($a1) cmp overload::StrVal($a2)); +} + +sub string +{ + my $self = shift; + + return overload::StrVal($self); +} + +sub render_stack +{ + my $self = shift; + my $var = shift; + + return $var; +} + +sub renderExp +{ + my $self = shift; + + return $self->renderGot($self->{val}); +} + +sub renderGot +{ + my $self = shift; + + return Test::Deep::render_val(@_); +} + +sub reset_arrow +{ + return 1; +} + +sub data +{ + my $self = shift; + + return $Test::Deep::Stack->getLast; +} + +1; diff --git a/lib/Test/Deep/Code.pm b/lib/Test/Deep/Code.pm new file mode 100644 index 0000000..ed9eaec --- /dev/null +++ b/lib/Test/Deep/Code.pm @@ -0,0 +1,58 @@ +use strict; +use warnings; + +package Test::Deep::Code; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $code = shift || die "No coderef supplied"; + + $self->{code} = $code; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my ($ok, $diag) = &{$self->{code}}($got); + + $self->data->{diag} = $diag; + + return $ok; +} + +sub diagnostics +{ + my $self = shift; + my ($where, $last) = @_; + + my $error = $last->{diag}; + my $data = Test::Deep::render_val($last->{got}); + my $diag = <{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + my $data = $self->data; + + return 0 unless Test::Deep::descend($got, $self->hash_keys($exp)); + + return 0 unless $self->test_class($got); + + return Test::Deep::descend($got, $self->hash_elements($exp)); +} + +sub hash_elements +{ + require Test::Deep::HashElements; + + my $self = shift; + + return Test::Deep::HashElements->new(@_); +} + +sub hash_keys +{ + require Test::Deep::HashKeys; + + my $self = shift; + my $exp = shift; + + return Test::Deep::HashKeys->new(keys %$exp); +} + +sub reset_arrow +{ + return 0; +} + +package Test::Deep::SuperHash; + +use base 'Test::Deep::Hash'; + +sub hash_elements +{ + require Test::Deep::HashElements; + + my $self = shift; + + return Test::Deep::SuperHashElements->new(@_); +} + +sub hash_keys +{ + require Test::Deep::HashKeys; + + my $self = shift; + my $exp = shift; + + return Test::Deep::SuperHashKeys->new(keys %$exp); +} + +package Test::Deep::SubHash; + +use base 'Test::Deep::Hash'; + +sub hash_elements +{ + require Test::Deep::HashElements; + + my $self = shift; + + return Test::Deep::SubHashElements->new(@_); +} + +sub hash_keys +{ + require Test::Deep::HashKeys; + + my $self = shift; + my $exp = shift; + + return Test::Deep::SubHashKeys->new(keys %$exp); +} + +1; diff --git a/lib/Test/Deep/HashEach.pm b/lib/Test/Deep/HashEach.pm new file mode 100644 index 0000000..3a3acf6 --- /dev/null +++ b/lib/Test/Deep/HashEach.pm @@ -0,0 +1,29 @@ +use strict; +use warnings; + +package Test::Deep::HashEach; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my %exp; + + @exp{keys %$got} = ($self->{val}) x (keys %$got); + + return Test::Deep::descend($got, \%exp); +} + +1; diff --git a/lib/Test/Deep/HashElements.pm b/lib/Test/Deep/HashElements.pm new file mode 100644 index 0000000..ba33ac1 --- /dev/null +++ b/lib/Test/Deep/HashElements.pm @@ -0,0 +1,94 @@ +use strict; +use warnings; + +package Test::Deep::HashElements; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + my $data = $self->data; + + my $master = $self->getMaster($got, $exp); + + foreach my $key (keys %$master) + { + $data->{index} = $key; + + my $got_elem = exists $got->{$key} ? $got->{$key} : $Test::Deep::DNE; + my $exp_elem = exists $exp->{$key} ? $exp->{$key} : $Test::Deep::DNE; + + next if Test::Deep::descend($got_elem, $exp_elem); + + return 0; + } + + return 1; +} + +sub getMaster +{ + my $self = shift; + + my ($got, $exp) = @_; + + return keys %$got > keys %$exp ? $got : $exp; +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + $var .= "->" unless $Test::Deep::Stack->incArrow; + $var .= '{"'.quotemeta($data->{index}).'"}'; + + return $var; +} + +sub reset_arrow +{ + return 0; +} + +package Test::Deep::SuperHashElements; + +use base 'Test::Deep::HashElements'; + +sub getMaster +{ + my $self = shift; + + my ($got, $exp) = @_; + + return $exp; +} + +package Test::Deep::SubHashElements; + +use base 'Test::Deep::HashElements'; + +sub getMaster +{ + my $self = shift; + + my ($got, $exp) = @_; + + return $got; +} + +1; diff --git a/lib/Test/Deep/HashKeys.pm b/lib/Test/Deep/HashKeys.pm new file mode 100644 index 0000000..46bf9cb --- /dev/null +++ b/lib/Test/Deep/HashKeys.pm @@ -0,0 +1,68 @@ +use strict; +use warnings; + +package Test::Deep::HashKeys; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my %keys; + @keys{@_} = (); + $self->{val} = \%keys; + $self->{keys} = [sort @_]; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + return 0 unless $self->test_reftype($got, "HASH"); + + return Test::Deep::descend($got, $self->hashkeysonly($exp)); +} + +sub hashkeysonly +{ + require Test::Deep::HashKeysOnly; + + my $self = shift; + my $exp = shift; + + return Test::Deep::HashKeysOnly->new(keys %$exp) +} + +package Test::Deep::SuperHashKeys; + +use base 'Test::Deep::HashKeys'; + +sub hashkeysonly +{ + require Test::Deep::HashKeysOnly; + + my $self = shift; + my $exp = shift; + + return Test::Deep::SuperHashKeysOnly->new(keys %$exp) +} + +package Test::Deep::SubHashKeys; + +use base 'Test::Deep::HashKeys'; + +sub hashkeysonly +{ + require Test::Deep::HashKeysOnly; + + my $self = shift; + my $exp = shift; + + return Test::Deep::SubHashKeysOnly->new(keys %$exp) +} + +1; diff --git a/lib/Test/Deep/HashKeysOnly.pm b/lib/Test/Deep/HashKeysOnly.pm new file mode 100644 index 0000000..c3fb59a --- /dev/null +++ b/lib/Test/Deep/HashKeysOnly.pm @@ -0,0 +1,126 @@ +use strict; +use warnings; + +package Test::Deep::HashKeysOnly; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my %keys; + @keys{@_} = (); + $self->{val} = \%keys; + $self->{keys} = [sort @_]; +} + +sub descend +{ + my $self = shift; + my $hash = shift; + + my $data = $self->data; + my $exp = $self->{val}; + my %got; + @got{keys %$hash} = (); + + my @missing; + my @extra; + + while (my ($key, $value) = each %$exp) + { + if (exists $got{$key}) + { + delete $got{$key}; + } + else + { + push(@missing, $key); + } + } + + my @diags; + if (@missing and (not $self->ignoreMissing)) + { + push(@diags, "Missing: ".nice_list(\@missing)); + } + + if (%got and (not $self->ignoreExtra)) + { + push(@diags, "Extra: ".nice_list([keys %got])); + } + + if (@diags) + { + $data->{diag} = join("\n", @diags); + return 0; + } + + return 1; +} + +sub diagnostics +{ + my $self = shift; + my ($where, $last) = @_; + + my $type = $self->{IgnoreDupes} ? "Set" : "Bag"; + + my $error = $last->{diag}; + my $diag = <SUPER::new; + +sub new +{ + return $Singleton; +} + +sub descend +{ + return 1; +} + +1; diff --git a/lib/Test/Deep/Isa.pm b/lib/Test/Deep/Isa.pm new file mode 100644 index 0000000..3d1ef97 --- /dev/null +++ b/lib/Test/Deep/Isa.pm @@ -0,0 +1,43 @@ +use strict; +use warnings; + +package Test::Deep::Isa; + +use Test::Deep::Cmp; +use Scalar::Util; + +sub init +{ + my $self = shift; + + my $val = shift; + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + return Scalar::Util::blessed($got) + ? $got->isa($self->{val}) + : ref($got) eq $self->{val}; +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Checking class of $where with isa()"; +} + +sub renderExp +{ + my $self = shift; + + return "blessed into or ref of type '$self->{val}'"; +} + +1; diff --git a/lib/Test/Deep/ListMethods.pm b/lib/Test/Deep/ListMethods.pm new file mode 100644 index 0000000..a7eff2b --- /dev/null +++ b/lib/Test/Deep/ListMethods.pm @@ -0,0 +1,24 @@ +use strict; +use warnings; + +package Test::Deep::ListMethods; + +use base 'Test::Deep::Methods'; + +sub call_method +{ + my $self = shift; + + return [$self->SUPER::call_method(@_)]; +} + +sub render_stack +{ + my $self = shift; + + my $var = $self->SUPER::render_stack(@_); + + return "[$var]"; +} + +1; diff --git a/lib/Test/Deep/MM.pm b/lib/Test/Deep/MM.pm new file mode 100644 index 0000000..49fdc28 --- /dev/null +++ b/lib/Test/Deep/MM.pm @@ -0,0 +1,64 @@ +use strict; +use warnings; + +package Test::Deep::MM; + +sub import +{ + my $self = shift; + + my ($pkg) = caller(); + my $mpkg = $pkg."::Methods"; + foreach my $attr (@_) + { + if ($attr =~ /^[a-z]/) + { + no strict 'refs'; + *{$mpkg."::$attr"} = \&{$attr}; + } + else + { + my $get_name = $mpkg."::get$attr"; + my $set_name = $mpkg."::set$attr"; + my $get_sub = sub { + return $_[0]->{$attr}; + }; + my $set_sub = sub { + return $_[0]->{$attr} = $_[1]; + }; + + { + no strict 'refs'; + *$get_name = $get_sub; + *$set_name = $set_sub; + push(@{$pkg."::ISA"}, $mpkg); + } + } + } +} + +sub new +{ + my $pkg = shift; + + my $self = bless {}, $pkg; + + $self->init(@_); + + return $self; +} + +sub init +{ + my $self = shift; + + while (@_) + { + my $name = shift || confess("No name"); + + my $method = "set$name"; + $self->$method(shift); + } +} + +1; diff --git a/lib/Test/Deep/Methods.pm b/lib/Test/Deep/Methods.pm new file mode 100644 index 0000000..ca5e6d6 --- /dev/null +++ b/lib/Test/Deep/Methods.pm @@ -0,0 +1,83 @@ +use strict; +use warnings; + +package Test::Deep::Methods; + +use Test::Deep::Cmp; +use Scalar::Util; + +sub init +{ + my $self = shift; + + # get them all into [$name,@args] => $value format + my @methods; + while (@_) + { + my $name = shift; + my $value = shift; + push(@methods, + [ + ref($name) ? $name : [ $name ], + $value + ] + ); + } + $self->{methods} = \@methods; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $data = $self->data; + + foreach my $method (@{$self->{methods}}) + { + $data->{method} = $method; + + my ($call, $exp_res) = @$method; + my ($name, @args) = @$call; + + local $@; + + my $got_res; + if (! eval { $got_res = $self->call_method($got, $call); 1 }) { + die $@ unless $@ =~ /\ACan't locate object method "\Q$name"/; + $got_res = $Test::Deep::DNE; + } + + next if Test::Deep::descend($got_res, $exp_res); + + return 0; + } + + return 1; +} + +sub call_method +{ + my $self = shift; + my ($got, $call) = @_; + my ($name, @args) = @$call; + + return $got->$name(@args); +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + + my $method = $data->{method}; + my ($call, $expect) = @$method; + my ($name, @args) = @$call; + + my $args = @args ? "(".join(", ", @args).")" : ""; + $var .= "->$name$args"; + + return $var; +} + +1; diff --git a/lib/Test/Deep/NoTest.pm b/lib/Test/Deep/NoTest.pm new file mode 100644 index 0000000..1764f56 --- /dev/null +++ b/lib/Test/Deep/NoTest.pm @@ -0,0 +1,41 @@ +use strict; +use warnings; + +# this is for people who don't want Test::Builder to be loaded but want to +# use eq_deeply. It's a bit hacky... + +package Test::Deep::NoTest; + +our $NoTest; + +{ + local $NoTest = 1; + require Test::Deep; +} + +sub import { + my $import = Test::Deep->can("import"); + # make the stack look like it should for use Test::Deep + my $pkg = shift; + unshift(@_, "Test::Deep"); + goto &$import; +} + +1; + +=head1 NAME + +Test::Deep::NoTest - Use Test::Deep outside of the testing framework + +=head1 SYNOPSIS + + use Test::Deep::NoTest; + + if (eq_deeply($a, $b)) { + print "they were deeply equal\n"; + } + +=head1 DESCRIPTION + +This exports all the same things as Test::Deep but it does not load +Test::Builder so it can be used in ordinary non-test situations. diff --git a/lib/Test/Deep/None.pm b/lib/Test/Deep/None.pm new file mode 100644 index 0000000..cfeb31e --- /dev/null +++ b/lib/Test/Deep/None.pm @@ -0,0 +1,62 @@ +use strict; +use warnings; + +package Test::Deep::None; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my @list = map { + eval { $_->isa('Test::Deep::None') } + ? @{ $_->{val} } + : $_ + } @_; + + $self->{val} = \@list; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + foreach my $cmp (@{$self->{val}}) + { + return 0 if Test::Deep::eq_deeply_cache($got, $cmp); + } + + return 1; +} + +sub renderExp +{ + my $self = shift; + + my @expect = map {; Test::Deep::wrap($_) } @{ $self->{val} }; + my $things = join(", ", map {$_->renderExp} @expect); + + return "None of ( $things )"; +} + +sub diagnostics +{ + my $self = shift; + my ($where, $last) = @_; + + my $got = $self->renderGot($last->{got}); + my $exp = $self->renderExp; + + my $diag = <{val} = shift(@_) + 0; + $self->{tolerance} = shift; +} + +sub descend +{ + my $self = shift; + my $got = shift; + $self->data->{got_string} = $got; + { + no warnings 'numeric'; + $got += 0; + } + + $self->data->{got} = $got; + if (defined(my $tolerance = $self->{tolerance})) + { + return abs($got - $self->{val}) <= $tolerance; + } + else + { + return $got == $self->{val}; + } +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Comparing $where as a number"; +} + +sub renderGot +{ + my $self = shift; + my $val = shift; + + my $got_string = $self->data->{got_string}; + if ("$val" ne "$got_string") + { + $got_string = $self->SUPER::renderGot($got_string); + return "$val ($got_string)" + } + else + { + return $val; + } +} +sub renderExp +{ + my $self = shift; + + my $exp = $self->{val}; + + if (defined(my $tolerance = $self->{tolerance})) + { + return "$exp +/- $tolerance"; + } + else + { + return $exp; + } +} + +1; diff --git a/lib/Test/Deep/Obj.pm b/lib/Test/Deep/Obj.pm new file mode 100644 index 0000000..f0e60ed --- /dev/null +++ b/lib/Test/Deep/Obj.pm @@ -0,0 +1,42 @@ +use strict; +use warnings; + +package Test::Deep::Obj; + +use Test::Deep::Cmp; +use Scalar::Util; + +sub init +{ + my $self = shift; + + my $val = shift; + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + return Scalar::Util::blessed($got) + && $got->isa($self->{val}); +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Checking class of $where with isa()"; +} + +sub renderExp +{ + my $self = shift; + + return "blessed into '$self->{val}' or subclass of '$self->{val}'"; +} + +1; diff --git a/lib/Test/Deep/Ref.pm b/lib/Test/Deep/Ref.pm new file mode 100644 index 0000000..30fc4a6 --- /dev/null +++ b/lib/Test/Deep/Ref.pm @@ -0,0 +1,36 @@ +use strict; +use warnings; + +package Test::Deep::Ref; + +use Test::Deep::Cmp; + +use Scalar::Util qw( blessed ); + +sub test_class +{ + my $self = shift; + my $got = shift; + + my $exp = $self->{val}; + + if ($Test::Deep::Snobby) + { + return Test::Deep::descend($got, Test::Deep::blessed(blessed($exp))); + } + else + { + return 1; + } +} + +sub test_reftype +{ + my $self = shift; + my $got = shift; + my $reftype = shift; + + return Test::Deep::descend($got, Test::Deep::reftype($reftype)); +} + +1; diff --git a/lib/Test/Deep/RefType.pm b/lib/Test/Deep/RefType.pm new file mode 100644 index 0000000..1c55f5d --- /dev/null +++ b/lib/Test/Deep/RefType.pm @@ -0,0 +1,46 @@ +use strict; +use warnings; + +package Test::Deep::RefType; + +use Test::Deep::Cmp; + +use Scalar::Util qw( reftype ); + +sub init +{ + my $self = shift; + + $self->{val} = shift; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + my $reftype = reftype($got); + + return Test::Deep::descend($reftype, Test::Deep::shallow($exp)); +} + +sub render_stack +{ + my $self = shift; + my $var = shift; + + return "reftype($var)"; +} + +sub renderGot +{ + my $self = shift; + + my $got = shift; + + $self->SUPER::renderGot(reftype($got)); +} + +1; diff --git a/lib/Test/Deep/Regexp.pm b/lib/Test/Deep/Regexp.pm new file mode 100644 index 0000000..da77cd4 --- /dev/null +++ b/lib/Test/Deep/Regexp.pm @@ -0,0 +1,102 @@ +use strict; +use warnings; + +package Test::Deep::Regexp; + +use Test::Deep::Cmp; +use Test::Deep::RegexpMatches; + +sub init +{ + my $self = shift; + + my $val = shift; + + $val = ref $val ? $val : qr/$val/; + + $self->{val} = $val; + + if (my $matches = shift) + { + $self->{matches} = Test::Deep::regexpmatches($matches, $val); + + $self->{flags} = shift || ""; + } +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $re = $self->{val}; + if (my $match_exp = $self->{matches}) + { + my $flags = $self->{flags}; + my @match_got; + if ($flags eq "g") + { + @match_got = $got =~ /$re/g; + } + else + { + @match_got = $got =~ /$re/; + } + + if (@match_got) + { + return Test::Deep::descend(\@match_got, $match_exp); + } + else + { + return 0; + } + } + else + { + return ($got =~ $re) ? 1 : 0; + } +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Using Regexp on $where"; +} + +sub render_stack1 +{ + my $self = shift; + + my $stack = shift; + return "($stack =~ $self->{regex})"; +} + +sub renderExp +{ + my $self = shift; + + return "$self->{val}"; +} + +sub renderGot +{ + my $self = shift; + my $got = shift; + + if (defined (my $class = Scalar::Util::blessed($got))) + { + my $ostr = qq{$got}; + if ($ostr ne overload::StrVal($got)) + { + return qq{'$ostr' (instance of $class)}; + } + } + + return Test::Deep::render_val($got); +} + +1; diff --git a/lib/Test/Deep/RegexpMatches.pm b/lib/Test/Deep/RegexpMatches.pm new file mode 100644 index 0000000..3245865 --- /dev/null +++ b/lib/Test/Deep/RegexpMatches.pm @@ -0,0 +1,51 @@ +use strict; +use warnings; + +package Test::Deep::RegexpMatches; + +use Test::Deep::Array; + +use base 'Test::Deep::Array'; + +use Scalar::Util qw( blessed ); + +sub init +{ + my $self = shift; + + my $val = shift; + + $val = Test::Deep::array($val) unless + blessed($val) and $val->isa("Test::Deep::Cmp"); + + $self->{val} = $val; + $self->{regex} = shift; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + return Test::Deep::descend($got, $self->{val}); +} + +sub render_stack +{ + my $self = shift; + + my $stack = shift; + + $stack = "[$stack =~ $self->{regex}]"; + + return $stack; +# return $self->SUPER::render_stack($stack); +} + +sub reset_arrow +{ + return 1; +} + +1; diff --git a/lib/Test/Deep/RegexpOnly.pm b/lib/Test/Deep/RegexpOnly.pm new file mode 100644 index 0000000..e85e4e8 --- /dev/null +++ b/lib/Test/Deep/RegexpOnly.pm @@ -0,0 +1,47 @@ +use strict; +use warnings; + +package Test::Deep::RegexpOnly; + +use Test::Deep::Cmp; + +use Scalar::Util qw( blessed ); + +sub init +{ + my $self = shift; + + my $val = shift; + + $val = ref $val ? $val : qr/$val/; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + my $got = shift; + + my $re = $self->{val}; + + return $got =~ $self->{val} ? 1 : 0; +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Using Regexp on $where"; +} + +sub renderExp +{ + my $self = shift; + + return "$self->{val}"; +} + +1; diff --git a/lib/Test/Deep/RegexpRef.pm b/lib/Test/Deep/RegexpRef.pm new file mode 100644 index 0000000..c9656ff --- /dev/null +++ b/lib/Test/Deep/RegexpRef.pm @@ -0,0 +1,43 @@ +use strict; +use warnings; + +package Test::Deep::RegexpRef; + +use Test::Deep::Ref; +use Test::Deep::RegexpVersion; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + if ($Test::Deep::RegexpVersion::OldStyle) { + return 0 unless $self->test_class($got, "Regexp"); + return 0 unless $self->test_reftype($got, "SCALAR"); + } else { + return 0 unless $self->test_reftype($got, "REGEXP"); + } + + return Test::Deep::descend($got, Test::Deep::regexprefonly($exp)); +} + +sub renderGot +{ + my $self = shift; + + return shift().""; +} + +1; diff --git a/lib/Test/Deep/RegexpRefOnly.pm b/lib/Test/Deep/RegexpRefOnly.pm new file mode 100644 index 0000000..6979748 --- /dev/null +++ b/lib/Test/Deep/RegexpRefOnly.pm @@ -0,0 +1,43 @@ +use strict; +use warnings; + +package Test::Deep::RegexpRefOnly; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + return $got eq $exp; +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + + return "m/$var/"; +} + +sub renderGot +{ + my $self = shift; + + return shift().""; +} + +1; diff --git a/lib/Test/Deep/RegexpVersion.pm b/lib/Test/Deep/RegexpVersion.pm new file mode 100644 index 0000000..458564b --- /dev/null +++ b/lib/Test/Deep/RegexpVersion.pm @@ -0,0 +1,11 @@ +use strict; +use warnings; + +package Test::Deep::RegexpVersion; + +# Older versions of Perl treated Regexp refs as opaque scalars blessed +# into the "Regexp" class. Several bits of code need this so we +# centralise the test for that kind of version. +our $OldStyle = ($] < 5.011); + +1; diff --git a/lib/Test/Deep/ScalarRef.pm b/lib/Test/Deep/ScalarRef.pm new file mode 100644 index 0000000..4f92f6d --- /dev/null +++ b/lib/Test/Deep/ScalarRef.pm @@ -0,0 +1,29 @@ +use strict; +use warnings; + +package Test::Deep::ScalarRef; + +use Test::Deep::Ref; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + my $exp = $self->{val}; + + return 0 unless $self->test_class($got); + return 0 unless $self->test_reftype($got, Scalar::Util::reftype($exp)); + return Test::Deep::descend($got, Test::Deep::scalarrefonly($exp)); +} + +1; diff --git a/lib/Test/Deep/ScalarRefOnly.pm b/lib/Test/Deep/ScalarRefOnly.pm new file mode 100644 index 0000000..60c8a54 --- /dev/null +++ b/lib/Test/Deep/ScalarRefOnly.pm @@ -0,0 +1,36 @@ +use strict; +use warnings; + +package Test::Deep::ScalarRefOnly; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + my $val = shift; + + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + + my $exp = $self->{val}; + + return Test::Deep::descend($$got, $$exp); +} + +sub render_stack +{ + my $self = shift; + my ($var, $data) = @_; + + return "\${$var}"; +} + +1; diff --git a/lib/Test/Deep/Set.pm b/lib/Test/Deep/Set.pm new file mode 100644 index 0000000..28294f9 --- /dev/null +++ b/lib/Test/Deep/Set.pm @@ -0,0 +1,193 @@ +use strict; +use warnings; + +package Test::Deep::Set; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + $self->{IgnoreDupes} = shift; + $self->{SubSup} = shift; + + $self->{val} = []; + + $self->add(@_); +} + +sub descend +{ + my $self = shift; + my $d1 = shift; + + my $d2 = $self->{val}; + + my $IgnoreDupes = $self->{IgnoreDupes}; + + my $data = $self->data; + + my $SubSup = $self->{SubSup}; + + my $type = $IgnoreDupes ? "Set" : "Bag"; + + my $diag; + + if (ref $d1 ne 'ARRAY') + { + my $got = Test::Deep::render_val($d1); + $diag = <= 0; $i--) + { + if (Test::Deep::eq_deeply_cache($got[$i], $expect)) + { + $found = 1; + push(@found, $expect); + splice(@got, $i, 1); + + last unless $IgnoreDupes; + } + } + + push(@missing, $expect) unless $found; + } + + my @diags; + if (@missing and $SubSup ne "sub" && $SubSup ne "none") + { + push(@diags, "Missing: ".nice_list(\@missing)); + } + + if (@got and $SubSup ne "sup" && $SubSup ne "none") + { + my $got = __PACKAGE__->new($IgnoreDupes, "", @got); + push(@diags, "Extra: ".nice_list($got->{val})); + } + + if (@found and $SubSup eq "none") + { + my $found = __PACKAGE__->new($IgnoreDupes, "", @found); + push(@diags, "Extra: ".nice_list($found->{val})); + } + + $diag = join("\n", @diags); + } + + if ($diag) + { + $data->{diag} = $diag; + + return 0; + } + else + { + return 1; + } +} + +sub diagnostics +{ + my $self = shift; + my ($where, $last) = @_; + + my $type = $self->{IgnoreDupes} ? "Set" : "Bag"; + $type = "Sub$type" if $self->{SubSup} eq "sub"; + $type = "Super$type" if $self->{SubSup} eq "sup"; + $type = "NoneOf" if $self->{SubSup} eq "none"; + + my $error = $last->{diag}; + my $diag = <{IgnoreDupes}; + + my $already = $self->{val}; + + local $Test::Deep::Expects = 1; + foreach my $new_elem (@array) + { + my $want_push = 1; + my $push_this = $new_elem; + foreach my $old_elem (@$already) + { + if (Test::Deep::eq_deeply($new_elem, $old_elem)) + { + $push_this = $old_elem; + $want_push = ! $IgnoreDupes; + last; + } + } + push(@$already, $push_this) if $want_push; + } + + # so we can compare 2 Test::Deep::Set objects using array comparison + + @$already = sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @$already; +} + +sub nice_list +{ + my $list = shift; + + my @scalars = grep ! ref $_, @$list; + my $refs = grep ref $_, @$list; + + my @ref_string = "$refs reference" if $refs; + $ref_string[0] .= "s" if $refs > 1; + + # sort them so we can predict the diagnostic output + + return join(", ", + (map {Test::Deep::render_val($_)} sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @scalars), + @ref_string + ); +} + +sub compare +{ + my $self = shift; + + my $other = shift; + + return 0 if $self->{IgnoreDupes} != $other->{IgnoreDupes}; + + # this works (kind of) because the arrays are sorted + + return Test::Deep::descend($self->{val}, $other->{val}); +} + +1; diff --git a/lib/Test/Deep/Shallow.pm b/lib/Test/Deep/Shallow.pm new file mode 100644 index 0000000..799d293 --- /dev/null +++ b/lib/Test/Deep/Shallow.pm @@ -0,0 +1,51 @@ +use strict; +use warnings; + +package Test::Deep::Shallow; + +use Test::Deep::Cmp; + +use Scalar::Util qw( refaddr ); + +sub init +{ + my $self = shift; + + my $val = shift; + $self->{val} = $val; +} + +sub descend +{ + my $self = shift; + + my $got = shift; + my $exp = $self->{val}; + + my $ok; + + if (!defined $got and !defined $exp) + { + $ok = 1; + } + elsif (defined $got xor defined $exp) + { + $ok = 0; + } + elsif (ref $got and ref $exp) + { + $ok = refaddr($got) == refaddr($exp); + } + elsif (ref $got xor ref $exp) + { + $ok = 0; + } + else + { + $ok = $got eq $exp; + } + + return $ok; +} + +1; diff --git a/lib/Test/Deep/Stack.pm b/lib/Test/Deep/Stack.pm new file mode 100644 index 0000000..9719bc4 --- /dev/null +++ b/lib/Test/Deep/Stack.pm @@ -0,0 +1,85 @@ +use strict; +use warnings; + +package Test::Deep::Stack; + +use Carp qw( confess ); +use Scalar::Util; + +use Test::Deep::MM qw( new init Stack Arrow ); + +sub init +{ + my $self = shift; + + $self->SUPER::init(@_); + + $self->setStack([]) unless $self->getStack; +} + +sub push +{ + my $self = shift; + + push(@{$self->getStack}, @_); +} + +sub pop +{ + my $self = shift; + + return pop @{$self->getStack}; +} + +sub render +{ + my $self = shift; + my $var = shift; + + my $stack = $self->getStack; + + $self->setArrow(0); + + foreach my $data (@$stack) + { + my $exp = $data->{exp}; + if (Scalar::Util::blessed($exp) and $exp->isa("Test::Deep::Cmp")) + { + $var = $exp->render_stack($var, $data); + + $self->setArrow(0) if $exp->reset_arrow; + } + else + { + confess "Don't know how to render '$exp'"; + } + } + + return $var; +} + +sub getLast +{ + my $self = shift; + + return $self->getStack->[-1]; +} + +sub incArrow +{ + my $self = shift; + + my $a = $self->getArrow; + $self->setArrow($a + 1); + + return $a; +} + +sub length +{ + my $self = shift; + + return @{$self->getStack} + 0; +} + +1; diff --git a/lib/Test/Deep/String.pm b/lib/Test/Deep/String.pm new file mode 100644 index 0000000..5ddb0b1 --- /dev/null +++ b/lib/Test/Deep/String.pm @@ -0,0 +1,34 @@ +use strict; +use warnings; + +package Test::Deep::String; + +use Test::Deep::Cmp; + +sub init +{ + my $self = shift; + + $self->{val} = shift; +} + +sub descend +{ + my $self = shift; + my $got = shift().""; + + $self->data->{got} = $got; + + return $got eq $self->{val}; +} + +sub diag_message +{ + my $self = shift; + + my $where = shift; + + return "Comparing $where as a string"; +} + +1; diff --git a/t/all.t b/t/all.t new file mode 100644 index 0000000..14628d5 --- /dev/null +++ b/t/all.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply(["wine"], all( [re(qr/^wi/)], [re(qr/ne$/)], ["wine"]) ) + }, + { + actual_ok => 1, + diag => "", + }, + "all eq" + ); + + check_test( + sub { + cmp_deeply(["wine"], all( [re(qr/^wi/)], [re(qr/ne$/)], ["wines"]) ) + }, + { + actual_ok => 0, + diag => <[0] + got : 'wine' +expect : 'wines' +EOM + }, + "all not eq" + ); + + check_tests( + sub { + cmp_deeply("wine", all(re("^wi")) & re('ne$'), "pass"); + cmp_deeply("wine", all(re("^wi")) & re('na$'), "fail"); + }, + [ + {actual_ok => 1}, + {actual_ok => 0} + ], + "all with &" + ); + + check_tests( + sub { + cmp_deeply("wine", re("^wi") & re('ne$'), "pass"); + cmp_deeply("wine", re("^wi") & re('na$'), "fail"); + }, + [ + {actual_ok => 1, diag => ""}, + {actual_ok => 0} + ], + "& without all" + ); +} diff --git a/t/any.t b/t/any.t new file mode 100644 index 0000000..a727cce --- /dev/null +++ b/t/any.t @@ -0,0 +1,61 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply("wine", any("beer", "wine")) + }, + { + actual_ok => 1, + diag => "", + }, + "any eq" + ); + + check_test( + sub { + cmp_deeply("whisky", any("beer", "wine")) + }, + { + actual_ok => 0, + diag => < 0, + diag => < 1 }, + { actual_ok => 0 } + ], + "| without any" + ); + +} diff --git a/t/array.t b/t/array.t new file mode 100644 index 0000000..215b4af --- /dev/null +++ b/t/array.t @@ -0,0 +1,76 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply(["a", "b"], ["a", "b"], "array eq"); + }, + { + name => "array eq", + actual_ok => 1, + diag => "", + } + ); + check_test( + sub { + cmp_deeply(["a", "b"], ["a", "c"], "array not eq"); + }, + { + name => "array not eq", + actual_ok => 0, + diag => <[1] + got : 'b' +expect : 'c' +EOM + } + ); + check_test( + sub { + cmp_deeply(["a", "b"], ["a"], "array got DNE"); + }, + { + name => "array got DNE", + actual_ok => 0, + diag => < "array expected DNE", + actual_ok => 0, + diag => < 0, + diag => <[0] + got : array with 1 element(s) +expect : array with 2 element(s) +EOM + }, + ], + "deep bad length" + ); +} diff --git a/t/array_each.t b/t/array_each.t new file mode 100644 index 0000000..a626941 --- /dev/null +++ b/t/array_each.t @@ -0,0 +1,34 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + my $re = qr/^wi/; + check_test( + sub { + cmp_deeply([qw( wine wind wibble winny window )], array_each( re($re) )) + }, + { + actual_ok => 1, + diag => "", + }, + "array_each eq" + ); + + check_test( + sub { + cmp_deeply([qw( wibble wobble winny window )], array_each( re($re) )) + }, + { + actual_ok => 0, + diag => <[1] + got : 'wobble' +expect : $re +EOM + }, + "array_each not eq" + ); +} diff --git a/t/arraylength.t b/t/arraylength.t new file mode 100644 index 0000000..ba7b50b --- /dev/null +++ b/t/arraylength.t @@ -0,0 +1,103 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_tests( + sub { + cmp_deeply([], arraylength(0), "0"); + cmp_deeply([1..3], arraylength(3), "3"); + }, + [ + { + name => "0", + actual_ok => 1, + diag => "", + }, + { + name => "3", + actual_ok => 1, + diag => "", + } + ], + "len ok" + ); + check_tests( + sub { + cmp_deeply({}, arraylength(2)); + }, + [ + { + actual_ok => 0, + diag => < 0, + diag => < "string", + actual_ok => 0, + diag => < "hash", + actual_ok => 0, + diag => < 0, + diag => <[0] + got : array with 1 element(s) +expect : array with 2 element(s) +EOM + }, + ], + "deep bad length" + ); +} diff --git a/t/bag.t b/t/bag.t new file mode 100644 index 0000000..82e7427 --- /dev/null +++ b/t/bag.t @@ -0,0 +1,282 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply([], bag()); + }, + { + actual_ok => 1, + diag => "", + }, + "empty eq" + ); + + check_test( + sub { + cmp_deeply(['a', 'b', 'b', ['c', 'd']], bag('b', 'a', ['c', 'd'], 'b')); + }, + { + actual_ok => 1, + diag => "", + }, + "elem eq" + ); + + check_test( + sub { + cmp_deeply(['a', [], 'b', 'b'], bag()); + }, + { + actual_ok => 0, + diag => < 0, + diag => < 0, + diag => < 0, + diag => < 1, + diag => '', + }, + "bag of bags eq" + ); + + check_test( + sub { + cmp_deeply(['a', ['a', 'b', 'b'], ['c', 'd', 'c'], ['a', 'b', 'a']], + bag(bag('c', 'd', 'd'), bag('a', 'b', 'a'), bag('a', 'b', 'b'), 'a') + ); + }, + { + actual_ok => 0, + diag => <add($b2, $b1); + $b2->[0]->add($b1, $b2); + + my $v1 = ['a']; + my $v2 = [['b']]; + push(@$v1, $v2, $v1); + push(@{$v2->[0]}, $v1, $v2); + + check_test( + sub { + cmp_deeply($v1, $b1); + }, + { + actual_ok => 1, + diag => '', + }, + "circular double bag eq" + ); + + $b1->add('b', 'b'); + push(@$v1, 'c', 'c'); + check_test( + sub { + cmp_deeply($v1, $b1); + }, + { + actual_ok => 0, + diag => < 1, + }, + "cmp_bag eq" + ); + + check_test( + sub { + cmp_bag([1, 2, 2], [1, 2, 1, 2]); + }, + { + actual_ok => 0, + }, + "cmp_bag not eq" + ); + + check_test( + sub { + cmp_bag([1], [1], 'name1'); + }, + { + actual_ok => 1, + name => 'name1', + }, + "cmp_bag returns name" + ); + + check_test( + sub { + cmp_bag([1], [2], 'name2'); + }, + { + actual_ok => 0, + name => 'name2', + }, + "cmp_bag returns name" + ); + + check_test( + sub { + cmp_deeply(['a', 'b', 'c', 'a', 'a', 'b'], superbagof('b', 'a', 'b')); + }, + { + actual_ok => 1, + diag => "", + }, + "superbagof yes" + ); + + check_test( + sub { + cmp_deeply(['a', 'b', 'c', 'a'], superbagof('d', 'b', 'd', 'b')); + }, + { + actual_ok => 0, + diag => <<'EOM', +Comparing $data as a SuperBag +Missing: 'b', 'd', 'd' +EOM + }, + "superbagof no" + ); + + check_test( + sub { + cmp_deeply(['b', 'a', 'b'], subbagof('a', 'b', 'c', 'a', 'a', 'b' )); + }, + { + actual_ok => 1, + diag => "", + }, + "subbagof yes" + ); + + check_test( + sub { + cmp_deeply(['d', 'b', 'd','b'], subbagof('a', 'b', 'c', 'a')); + }, + { + actual_ok => 0, + diag => <<'EOM', +Comparing $data as a SubBag +Extra: 'b', 'd', 'd' +EOM + }, + "subbagof no" + ); +{ + check_test( + sub { + cmp_deeply(['a', 'a', 'b', 'c', 'b'], noneof('d', 'e', 'f')); + }, + { + actual_ok => 1, + diag => "", + }, + "noneof yes" + ); + + check_test( + sub { + cmp_deeply(['a', 'a', 'b', 'c', 'b'], noneof('b', 'c', 'd', 'e')); + }, + { + actual_ok => 0, + diag => <<'EOM', +Comparing $data as a NoneOf +Extra: 'b', 'c' +EOM + }, + "noneof no" + ); +} + + + eval { + my @res = run_tests( + sub { cmp_bag([], {}) } + ) + }; + like($@, qr/Argument 2 to cmp_bag is not an ARRAY ref \(HASH.*\)/, + "check arg 1") +} diff --git a/t/bagrecursion.t b/t/bagrecursion.t new file mode 100644 index 0000000..beb6451 --- /dev/null +++ b/t/bagrecursion.t @@ -0,0 +1,12 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +# just want to make sure this doesn't go into an infitite recursion + +my @methods=(methods(hello=>'world'),methods(goodbye=>'world')); +my $bag_o_methods=bag(@methods); + +ok(1, "no inifinite recursion"); diff --git a/t/blessed.t b/t/blessed.t new file mode 100644 index 0000000..2f4b7d2 --- /dev/null +++ b/t/blessed.t @@ -0,0 +1,62 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + my $b = bless [], "class"; + check_test( + sub { + cmp_deeply($b, blessed("class")); + }, + { + actual_ok => 1, + diag => '', + }, + "Same" + ); + + check_test( + sub { + cmp_deeply($b, blessed("other")); + }, + { + actual_ok => 0, + diag => < 1, + diag => '', + }, + "Same" + ); + + check_test( + sub { + cmp_deeply([], blessed("class")); + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }) x 4 + ], + "ok" + ); + + check_tests( + sub { + cmp_deeply(1, bool(0), "num 1"); + cmp_deeply("abds", bool(0), "string"); + cmp_deeply(0, bool(1), "num 0"); + cmp_deeply("", bool(1), "string"); + }, + [ + { + actual_ok => 0, + diag => < 0, + }) x 3, + ], + "string not eq" + ); +} diff --git a/t/cache.t b/t/cache.t new file mode 100644 index 0000000..dbb8d25 --- /dev/null +++ b/t/cache.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More 0.88; +use if $ENV{AUTHOR_TESTING}, 'Test::Warnings'; + +use Test::Deep::Cache; + +{ + local $Test::Deep::Expects = 0; + my $cache = Test::Deep::Cache->new; + + my $a = \"a"; + my $b = \"b"; + my $c = []; + + ok(! $cache->cmp($a, $b), "empty cache"); + + $cache->add($a, $b); + + ok($cache->cmp($a, $b), "added"); + ok($cache->cmp($b, $a), "reverse"); + + $cache->local; + + ok($cache->cmp($a, $b), "after local"); + + $cache->add($b, $c); + ok($cache->cmp($b, $c), "local added"); + $cache->finish(0); + ok(! $cache->cmp($b, $c), "gone"); + + $cache->local; + + $cache->add($b, $c); + ok($cache->cmp($b, $c), "local added again"); + $cache->finish(1); + ok($cache->cmp($b, $c), "still there"); +} + +done_testing; diff --git a/t/circular.t b/t/circular.t new file mode 100644 index 0000000..57a3b8c --- /dev/null +++ b/t/circular.t @@ -0,0 +1,146 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + my $a1 = gen_layers(2); + my $a2 = gen_layers(2); + + check_test( + sub { + cmp_deeply($a1, $a2); + }, + { + actual_ok => 1, + diag => "", + }, + "2 layers" + ); + + push(@$a1, "break"); + check_test( + sub { + cmp_deeply($a1, $a2); + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "2 layers fixed" + ); +} + +{ + my $a1 = gen_layers(2); + my $a2 = gen_layers(3); + + check_test( + sub { + cmp_deeply($a1, $a2); + }, + { + actual_ok => 1, + diag => "", + }, + "2 and 3 layers" + ); + push(@$a1, "break"); + check_test( + sub { + cmp_deeply($a1, $a2); + }, + { + actual_ok => 0, + diag => < 0, + diag => <[2][2] + got : array with 4 element(s) +expect : array with 3 element(s) +EOM + }, + "2 and 3 layers not fixed" + ); +} + +{ + my $a1 = gen_interleave(); + my $a2 = gen_interleave(); + + check_test( + sub { + cmp_deeply($a1, $a2); + }, + { + actual_ok => 1, + diag => "", + }, + "interleave" + ); +} + +sub gen_layers +{ + my $num = shift; + + my $first = ['text', gen_circle()]; + $num--; + my $last = $first; + while ($num--) + { + my $next = ['text', gen_circle()]; + push(@$last, $next); + $last = $next; + } + + push(@$last, $first); + return $first +} + +sub gen_circle +{ + my $a = ['circle']; + push(@$a, $a); + return $a +} + +sub gen_interleave +{ + my $a = []; + my $b = []; + + push(@$a, $b, $a); + push(@$b, $a, $b); + + return $a; +} diff --git a/t/class.t b/t/class.t new file mode 100644 index 0000000..0f21536 --- /dev/null +++ b/t/class.t @@ -0,0 +1,99 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + my $bless_a = bless {}, "A::Class"; + my $bless_b = bless {}, "B::Class"; + my $nobless = {}; + + check_test( + sub { + cmp_deeply([$bless_a], [noclass($bless_b)]); + }, + { + actual_ok => 1, + diag => "", + }, + "no class eq" + ); + + check_test( + sub { + cmp_deeply([$bless_a], [noclass($nobless)]); + }, + { + actual_ok => 1, + diag => "", + }, + "no class eq unblessed" + ); + + check_test( + sub { + cmp_deeply([$bless_a], [$bless_b]); + }, + { + actual_ok => 0, + diag => <[0]) + got : 'A::Class' +expect : 'B::Class' +EOM + }, + "class not eq" + ); + + check_test( + sub { + cmp_deeply([$bless_a], [$nobless]); + }, + { + actual_ok => 0, + diag => <[0]) + got : 'A::Class' +expect : undef +EOM + }, + "class not eq unblessed" + ); + + my $bless_c = bless [$bless_a], "C::Class"; + + check_test( + sub { + cmp_deeply( + $bless_c, + bless([noclass($nobless)], "C::Class") + ); + }, + { + actual_ok => 1, + diag => "", + }, + "class eq on/off" + ); + + my $bless_d = bless [$bless_c], "D::Class"; + + check_test( + sub { + cmp_deeply( + $bless_d, + bless([noclass(bless([useclass(bless({}, "NotA::Class"))], "NotC::Class"))], "D::Class"), + ); + }, + { + actual_ok => 0, + diag => <[0]->[0]) + got : 'A::Class' +expect : 'NotA::Class' +EOM + }, + "class eq on/off/on" + ); +} diff --git a/t/code.t b/t/code.t new file mode 100644 index 0000000..4e3b5de --- /dev/null +++ b/t/code.t @@ -0,0 +1,63 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +sub cmp +{ + my $str = shift; + + if ($str eq "fergal") + { + return 1; + } + elsif ($str eq "feargal") + { + return (0, "your name's not down, you're not coming in"); + } + else + { + return 0; + } +} + +{ + check_test( + sub { + cmp_deeply("fergal", code(\&cmp)); + }, + { + actual_ok => 1, + diag => '', + }, + "code ok" + ); + + my ($prem, $res); + ($prem, $res) = check_test( + sub { + cmp_deeply("feargal", code(\&cmp)); + }, + { + actual_ok => 0, + }, + "code not ok" + ); + + like($res->{diag}, "/your name's not down/", "diagnostics"); + like($res->{diag}, "/feargal/", "diagnostics"); + + ($prem, $res) = check_test( + sub { + cmp_deeply("fazzer", code(\&cmp)); + }, + { + actual_ok => 0, + }, + "code not ok" + ); + + like($res->{diag}, "/it failed but it didn't say why/", "no diagnostics"); + like($res->{diag}, "/fazzer/", "no diagnostics"); +} diff --git a/t/deep_utils.t b/t/deep_utils.t new file mode 100644 index 0000000..082c63d --- /dev/null +++ b/t/deep_utils.t @@ -0,0 +1,30 @@ +use strict; +use warnings; + +use Test::More 0.88; +use if $ENV{AUTHOR_TESTING}, 'Test::Warnings'; + +use Test::Deep qw( cmp_deeply descend render_stack methods deep_diag ); + +{ + my $a = []; + + my $base = Test::Deep::_td_reftype($a); + is($base, "ARRAY", "_td_reftype base ref"); +} + +{ + my $a = bless [], "A::Class"; + + my $base = Test::Deep::_td_reftype($a); + is($base, "ARRAY", "_td_reftype base obj"); +} + +{ + my $a = qr/a/; + + my $base = Test::Deep::_td_reftype($a); + is($base, ($] < 5.011 ? "Regexp" : "REGEXP"), "class_base base regexp"); +} + +done_testing; diff --git a/t/descend.t b/t/descend.t new file mode 100644 index 0000000..e5efd07 --- /dev/null +++ b/t/descend.t @@ -0,0 +1,139 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply("a", "a", "scalar eq"); + }, + { + name => "scalar eq", + actual_ok => 1, + diag => "", + } + ); + + check_test( + sub { + cmp_deeply("a", "b", "scalar not eq"); + }, + { + name => "scalar not eq", + actual_ok => 0, + diag => < "def undef", + actual_ok => 0, + diag => < "undef def", + actual_ok => 0, + diag => < "undef undef", + actual_ok => 1, + diag => '', + } + ); + check_test( + sub { + cmp_deeply("", undef); + }, + { + actual_ok => 0, + diag => < "ref ref eq", + actual_ok => 1, + diag => "", + } + ); + check_test( + sub { + cmp_deeply(\\"a", \\"b", "ref ref not eq"); + }, + { + name => "ref ref not eq", + actual_ok => 0, + diag => < 1, + diag => "", + }, + "equal refs" + ); +} + +{ + my @a; + check_test( + sub { + cmp_deeply(undef, \@a); + }, + { + actual_ok => 0, + }, + "not calling StrVal on undef" + ); +} diff --git a/t/error.t b/t/error.t new file mode 100644 index 0000000..e29fd3c --- /dev/null +++ b/t/error.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + my ($prem, @res) = eval { + run_tests( + sub { + cmp_deeply([shallow([])], [[]], "bad special"); + } + ); + }; + + like($@, qr/^Found a special comparison in \$data->\[0\]\nYou can only use specials in the expects structure/, + "bad special"); +} diff --git a/t/hash.t b/t/hash.t new file mode 100644 index 0000000..22f2100 --- /dev/null +++ b/t/hash.t @@ -0,0 +1,86 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply({key1 => "a", key2 => "b"}, {key1 => "a", key2 => "b"}, + "hash eq"); + }, + { + name => "hash eq", + actual_ok => 1, + diag => "", + } + ); + check_test( + sub { + cmp_deeply({key1 => "a", key2 => "b"}, {key1 => "a", key2 => "c"}, + "hash not eq"); + }, + { + name => "hash not eq", + actual_ok => 0, + diag => <{"key2"} + got : 'b' +expect : 'c' +EOM + } + ); + check_test( + sub { + cmp_deeply({key1 => "a"}, {key1 => "a", key2 => "c"}, + "hash got DNE"); + }, + { + name => "hash got DNE", + actual_ok => 0, + diag => < "a", key2 => "c"}, {key1 => "a"}, + "hash expected DNE"); + }, + { + name => "hash expected DNE", + actual_ok => 0, + diag => < "a", key2 => "c"}, superhashof({key1 => "a"}), + "superhash ok"); + }, + { + name => "superhash ok", + actual_ok => 1, + diag => "", + } + ); + + check_test( + sub { + cmp_deeply({key1 => "a"}, subhashof({key1 => "a", key2 => "c"}), + "subhash ok"); + }, + { + name => "subhash ok", + actual_ok => 1, + diag => "", + } + ); +} diff --git a/t/hash_each.t b/t/hash_each.t new file mode 100644 index 0000000..b3d4804 --- /dev/null +++ b/t/hash_each.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + my $re = qr/^wi/; + check_test( + sub { + cmp_deeply( + { a => 'wine', b => 'wind', c => 'wibble'}, + hash_each( re($re) ) + ) + }, + { + actual_ok => 1, + diag => "", + }, + "hash_each eq" + ); + + check_test( + sub { + cmp_deeply( + { a => 'wine', b => 'wand', c => 'wibble'}, + hash_each( re($re) ) + ) + }, + { + actual_ok => 0, + diag => <{"b"} + got : 'wand' +expect : $re +EOM + }, + "hash_each not eq" + ); +} diff --git a/t/hashkeys.t b/t/hashkeys.t new file mode 100644 index 0000000..1c45c1d --- /dev/null +++ b/t/hashkeys.t @@ -0,0 +1,70 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_tests( + sub { + cmp_deeply({}, hashkeys(), "0"); + cmp_deeply({1 => 2, 3 => 4, 5 => 6}, hashkeys(1, 3, 5), "3"); + }, + [ + { + name => "0", + actual_ok => 1, + diag => "", + }, + { + name => "3", + actual_ok => 1, + diag => "", + } + ], + "keys ok" + ); + check_tests( + sub { + cmp_deeply({a => 2, b => 4}, hashkeys("a", "c")); + }, + [ + { + actual_ok => 0, + diag => < "string", + actual_ok => 0, + diag => < "array", + actual_ok => 0, + diag => < 1, + diag => "", + }, + "ignore" + ); +} diff --git a/t/import.t b/t/import.t new file mode 100644 index 0000000..8866769 --- /dev/null +++ b/t/import.t @@ -0,0 +1,9 @@ +use strict; +use warnings; + +use Test::More tests => 2; +use Test::Deep 'all'; + +ok(defined &all); +ok(! defined &any); + diff --git a/t/isa.t b/t/isa.t new file mode 100644 index 0000000..892ed8d --- /dev/null +++ b/t/isa.t @@ -0,0 +1,149 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + my $a = {}; + + check_test( + sub { + cmp_deeply($a, isa("HASH")); + }, + { + actual_ok => 1, + diag => "", + }, + "isa eq" + ); + + check_test( + sub { + cmp_deeply($a, obj_isa("HASH")); + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "isa eq" + ); + + check_test( + sub { + cmp_deeply($b, obj_isa("B")); + }, + { + actual_ok => 1, + diag => "", + }, + "isa eq" + ); + + + check_test( + sub { + cmp_deeply($b, isa("A")); + }, + { + actual_ok => 0, + diag => < 0, + diag => < 1, + diag => "", + }, + "isa eq" + ); + + check_test( + sub { + cmp_deeply($b, obj_isa("A")); + }, + { + actual_ok => 1, + diag => "", + }, + "isa eq" + ); +} + +package A; + +use Test::Deep; +@A::ISA = qw( Test::Deep ); + +{ + ::ok(A->isa("Test::Deep"), "U::isa says yes"); + ::ok(! A->isa("Test"), "U::isa says yes"); +} + + +{ + package C; + use base 'A'; +} +package main; +{ + my $c = bless {}, "C"; + check_test( + sub { + cmp_deeply($c, isa("A")); + }, + { + actual_ok => 1, + diag => "", + }, + "isa eq" + ); +} + diff --git a/t/leaf-wrapper.t b/t/leaf-wrapper.t new file mode 100644 index 0000000..e1161d1 --- /dev/null +++ b/t/leaf-wrapper.t @@ -0,0 +1,68 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply( Test::Deep::EqOverloaded->new, 5); + }, + { + actual_ok => 0, + }, + "comparing a plain scalar leaf against obj without eq" + ); + + { + local $Test::Deep::LeafWrapper = \&str; + check_tests( + sub { + cmp_deeply( Test::Deep::EqOverloaded->new, 5); + cmp_deeply( Test::Deep::EqOverloaded->new, 6); + }, + [ + { + actual_ok => 1, + }, + { + actual_ok => 0, + }, + ], + "comparing a plain scalar leaf against obj with eq" + ); + } + + { + check_tests( + sub { + my $t1 = 5; + my $t2 = any(5); + my $t3 = all(5); + local $Test::Deep::LeafWrapper = \&str; + cmp_deeply(Test::Deep::EqOverloaded->new, $t1); + cmp_deeply(Test::Deep::EqOverloaded->new, $t2); + cmp_deeply(Test::Deep::EqOverloaded->new, $t3); + }, + [ + { + actual_ok => 1, + }, + { + actual_ok => 1, + }, + { + actual_ok => 1, + }, + ], + "comparing a plain scalar leaf against obj with eq via any() and all()" + ); + } +} + +{ + package Test::Deep::EqOverloaded; + use overload q{""} => sub { "5" }, fallback => 1; + sub new { my $self = {}; bless $self; } +} diff --git a/t/lib/Over.pm b/t/lib/Over.pm new file mode 100644 index 0000000..79eabd2 --- /dev/null +++ b/t/lib/Over.pm @@ -0,0 +1,22 @@ +use strict; +use warnings; + +package Over; + +use overload '""' => \&val, '0+' => \&val, fallback => 1; + +sub new +{ + my $pkg = shift; + my $val = shift; + + return bless \$val, $pkg; +} + +sub val +{ + my $self = shift; + return $$self; +} + +1; diff --git a/t/lib/Std.pm b/t/lib/Std.pm new file mode 100644 index 0000000..3a4e11b --- /dev/null +++ b/t/lib/Std.pm @@ -0,0 +1,14 @@ +use strict; +use warnings; + +use Test::Tester; +use Test::More 0.88; +use if $ENV{AUTHOR_TESTING}, 'Test::Warnings'; + +use Test::Deep; + +Test::Deep::builder(Test::Tester::capture()); + +END { done_testing; } + +1; diff --git a/t/listmethods.t b/t/listmethods.t new file mode 100644 index 0000000..7da4f54 --- /dev/null +++ b/t/listmethods.t @@ -0,0 +1,148 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +foreach my $thing (fake->new, 'fake') +{ + check_test( + sub { + cmp_deeply($thing, listmethods(meth1 => ["val1"], meth2 => ['a', 'b'])); + }, + { + actual_ok => 1, + diag => "", + }, + "listmethods eq" + ); + check_test( + sub { + cmp_deeply($thing, listmethods(meth1 => ["val1"], meth2 => ['a', 'c'])); + }, + { + actual_ok => 0, + diag => <meth2]->[1] + got : 'b' +expect : 'c' +EOM + }, + "listmethods not eq" + ); + check_test( + sub { + cmp_deeply($thing, listmethods(['plus1', 2] => ["a", "a", "a"])); + }, + { + actual_ok => 1, + diag => "", + }, + "listmethods arg eq" + ); + check_test( + sub { + cmp_deeply($thing, listmethods(['plus1', 2] => ["a", "b", "a"])); + }, + { + actual_ok => 0, + diag => <plus1(2)]->[1] + got : 'a' +expect : 'b' +EOM + }, + "listmethods arg not eq" + ); + + my $v3 = ['val3']; + check_test( + sub { + cmp_deeply($thing, listmethods(meth1 => ["val1"], meth3 => $v3)); + }, + { + actual_ok => 0, + diag => <meth3] + got : Does not exist +expect : $v3 +EOM + }, + "listmethods DNE" + ); +} + +{ + my $obj = fake->new; + + check_test( + sub { + cmp_deeply( + { + key => [ + \"a", \["b"], \$obj + ] + }, + { + key => [ + \"a", \["b"], \(listmethods(meth1 => ["val1"], meth2 => ['a', 'b'])) + ] + } + ); + }, + { + actual_ok => 1, + diag => "", + }, + "complex eq" + ); + check_test( + sub { + cmp_deeply( + { + key => [ + \"a", \["b"], \$obj + ] + }, + { + key => [ + \"a", \["b"], \(listmethods(meth1 => ["val1"], meth2 => ['a', 'c'])) + ] + } + ); + }, + { + actual_ok => 0, + diag => <{"key"}[2]}->meth2]->[1] + got : 'b' +expect : 'c' +EOM + }, + "complex not eq" + ); +} + +package fake; + +sub new +{ + return bless {}, __PACKAGE__; +} + +sub meth1 +{ + return "val1"; +} + +sub meth2 +{ + return ('a', 'b'); +} + +sub plus1 +{ + my $self = shift; + my $arg = shift; + return ("a") x ($arg + 1); +} diff --git a/t/memory.t b/t/memory.t new file mode 100644 index 0000000..4f7c136 --- /dev/null +++ b/t/memory.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::Tester; +use Test::More; + +BEGIN +{ + require Scalar::Util; + if (grep /^weaken$/, @Scalar::Util::EXPORT_FAIL) + { + plan(skip_all => "no weak refs in this version of perl"); + exit(0); + } +}use lib 't/lib'; + +use Std; + +use Scalar::Util qw( isweak weaken); + +sub left +{ + my $ref = shift; + eq_deeply($ref, []); + return "left"; +} + +sub right +{ + my $ref = shift; + eq_deeply([], $ref); + return "right"; +} + +my @subs = (\&left, \&right); +for my $sub (@subs) +{ + my $ref = []; + + my $weak = $ref; + weaken($weak); + my $side = &$sub($ref, []); + $ref = 1; + ok((! $weak), "$side didn't capture") || diag "weak = $weak"; +} diff --git a/t/methods.t b/t/methods.t new file mode 100644 index 0000000..ce1dff7 --- /dev/null +++ b/t/methods.t @@ -0,0 +1,168 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +foreach my $thing (fake->new, 'fake') +{ + check_test( + sub { + cmp_deeply($thing, methods(meth1 => "val1", meth2 => ['a', 'b'])); + }, + { + actual_ok => 1, + diag => "", + }, + "methods eq" + ); + check_test( + sub { + cmp_deeply($thing, methods(meth1 => "val1", meth2 => ['a', 'c'])); + }, + { + actual_ok => 0, + diag => <meth2->[1] + got : 'b' +expect : 'c' +EOM + }, + "methods not eq" + ); + check_test( + sub { + cmp_deeply($thing, methods(['plus1', 2] => 3)); + }, + { + actual_ok => 1, + diag => "", + }, + "methods arg eq" + ); + check_test( + sub { + cmp_deeply($thing, methods(['plus1', 2] => 2)); + }, + { + actual_ok => 0, + diag => <plus1(2) + got : '3' +expect : '2' +EOM + }, + "methods arg not eq" + ); + + check_test( + sub { + cmp_deeply($thing, methods(meth1 => "val1", meth3 => "val3")); + }, + { + actual_ok => 0, + diag => <meth3 + got : Does not exist +expect : 'val3' +EOM + }, + "methods DNE" + ); +} + +{ + my $obj = fake->new; + + check_test( + sub { + cmp_deeply( + { + key => [ + \"a", \["b"], \$obj + ] + }, + { + key => [ + \"a", \["b"], \(methods(meth1 => "val1", meth2 => ['a', 'b'])) + ] + } + ); + }, + { + actual_ok => 1, + diag => "", + }, + "complex eq" + ); + check_test( + sub { + cmp_deeply( + { + key => [ + \"a", \["b"], \$obj + ] + }, + { + key => [ + \"a", \["b"], \(methods(meth1 => "val1", meth2 => ['a', 'c'])) + ] + } + ); + }, + { + actual_ok => 0, + diag => <{"key"}[2]}->meth2->[1] + got : 'b' +expect : 'c' +EOM + }, + "complex not eq" + ); + + check_test( + sub { + cmp_methods($obj, [meth1 => "val1", meth2 => ['a', 'b']]); + }, + { + actual_ok => 1, + diag => "", + }, + "methods eq" + ); + check_test( + sub { + cmp_methods($obj, [meth1 => "val1", meth2 => ['a', 'c']]); + }, + { + actual_ok => 0, + }, + "methods not eq" + ); + +} + +package fake; + +sub new +{ + return bless {}, __PACKAGE__; +} + +sub meth1 +{ + return "val1"; +} + +sub meth2 +{ + return ['a', 'b']; +} + +sub plus1 +{ + my $self = shift; + my $arg = shift; + return $arg + 1; +} diff --git a/t/none.t b/t/none.t new file mode 100644 index 0000000..b98a143 --- /dev/null +++ b/t/none.t @@ -0,0 +1,70 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply("wine", none("beer", "wine")) + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "none eq ok" + ); + + check_test( + sub { + cmp_deeply("whisky", none("beer") | "wine") + }, + { + actual_ok => 1, + diag => "", + }, + "none with | match none" + ); + + check_test( + sub { + cmp_deeply("wine", none("beer") | "wine") + }, + { + actual_ok => 1, + diag => "", + }, + "none with | match alternative" + ); + + check_test( + sub { + cmp_deeply("beer", none("beer") | "wine") + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "number eq" + ); + + check_test( + sub { + cmp_deeply(1, num(2)) + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "funny number eq" + ); + + check_test( + sub { + cmp_deeply("1a", num(2)) + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "number tolerance eq" + ); + + check_test( + sub { + cmp_deeply(1, num(2, .5)) + }, + { + actual_ok => 0, + diag => <new(1); + + check_test( + sub { + cmp_deeply($o, num(1)) + }, + { + actual_ok => 1, + diag => "", + }, + "over number eq" + ); + + check_test( + sub { + cmp_deeply($o, num(2)) + }, + { + actual_ok => 0, + diag => < 1, + diag => '', + }, + "ARRAY ok" + ); + + check_test( + sub { + cmp_deeply([], reftype("HASH")); + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "re eq" + ); + + check_test( + sub { + cmp_deeply("fergal", regexponly($re)); + }, + { + actual_ok => 1, + diag => "", + }, + "regexponly eq" + ); + + check_test( + sub { + cmp_deeply("feargal", re($re)); + }, + { + actual_ok => 0, + diag => < 0, + diag => < 1, + diag => "", + }, + "string re eq" + ); + + check_test( + sub { + cmp_deeply("feargal", re($str)); + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "matches re eq" + ); + + check_test( + sub { + cmp_deeply("abc", re($re, [qw( a c )], "g")); + }, + { + actual_ok => 1, + diag => "", + }, + "matches global re eq" + ); + + check_test( + sub { + cmp_deeply("abc", re($re, [qw( a b )], "g")); + }, + { + actual_ok => 0, + diag => <[1] + got : 'c' +expect : 'b' +EOM + }, + "matches global not eq" + ); + +} + +{ + my $re = qr/(..)/; + check_test( + sub { + cmp_deeply("abababcdcdefef", re($re, set(qw( ab cd ef )), "g")); + }, + { + actual_ok => 1, + diag => "", + }, + "matches re and set eq" + ); + + check_test( + sub { + cmp_deeply("cat=2,dog=67,sheep=3,goat=2,dog=5", + re(qr/(\D+)=\d+,?/, set(qw( cat sheep dog )), "g")) + }, + { + actual_ok => 0, + diag => <new("hi mom"); + + is("$o", "hi mom", "we make a stringifiable object"); + + check_test( + sub { cmp_deeply($o, re(qr/mom/)); }, + { actual_ok => 1 }, + "re() tests objects via overloading", + ); + + # Remember, Regexp stringification changes over time. -- rjbs, 2016-09-08 + my $re = qr/dad/; + my $re_str = "$re"; + check_test( + sub { cmp_deeply($o, re($re)); }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "re eq" + ); + + check_test( + sub { + cmp_deeply("feargal", re($re)); + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "string re eq" + ); + + check_test( + sub { + cmp_deeply("feargal", re($str)); + }, + { + actual_ok => 0, + diag => < "regexp ref eq", + actual_ok => 1, + diag => "", + } + ); + check_test( + sub { + cmp_deeply(qr/a/, qr/b/, "regexp ref not eq"); + }, + { + name => "regexp ref not eq", + actual_ok => 0, + diag => < 'all'; +use lib 't/lib'; + +use Std; + +check_test( + sub { cmp_deeply('Foo', isa('Foo')) }, + { + actual_ok => 0, + diag => < 0, + diag => < 0, + diag => < 0, + diag => <[0] + got : '$a' +expect : $a +EOM + }, + "shallow not eq" + ); + + check_test( + sub { + cmp_deeply([$a, ["b"]], [shallow($a), ["a"]]); + }, + { + actual_ok => 0, + diag => <[1][0] + got : 'b' +expect : 'a' +EOM + }, + "deep after shallow not eq" + ); +} diff --git a/t/scalarref.t b/t/scalarref.t new file mode 100644 index 0000000..94777a3 --- /dev/null +++ b/t/scalarref.t @@ -0,0 +1,47 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply(\"a", \"a", "scalar ref eq"); + }, + { + name => "scalar ref eq", + actual_ok => 1, + diag => "", + } + ); + check_test( + sub { + cmp_deeply(\"a", \"b", "scalar ref not eq"); + }, + { + name => "scalar ref not eq", + actual_ok => 0, + diag => < "scalar ref not ref", + actual_ok => 0, + diag => < 1, + diag => "", + }, + "empty eq" + ); + + check_test( + sub { + cmp_deeply(["a"], set("a", "a")); + }, + { + actual_ok => 1, + diag => "", + }, + "empty eq" + ); + + check_test( + sub { + cmp_deeply(['a', 'b', 'b', ['c', 'd']], set('b', 'a', ['c', 'd'], 'b')); + }, + { + actual_ok => 1, + diag => "", + }, + "3 elem eq" + ); + + check_test( + sub { + cmp_deeply(['a', [], 'b', 'b'], set()); + }, + { + actual_ok => 0, + diag => < 0, + diag => < 0, + diag => < 0, + diag => < 1, + diag => '', + }, + "set of sets eq" + ); + check_test( + sub { + cmp_deeply([['a', 'b', 'c'], ['c', 'd', 'c'], ['a', 'b', 'a']], + set(set('c', 'd', 'c'), set('a', 'b', 'a'), set('b', 'b', 'a')) + ); + }, + { + actual_ok => 0, + diag => <add($b1, $b2, $b1); + $b2->[0]->add($b2, $b1, $b2); + + my $v1 = ['a']; + my $v2 = [['b']]; + push(@$v1, $v2, $v1, $v2); + push(@{$v2->[0]}, $v1, $v2, $v1); + + check_test( + sub { + cmp_deeply($v1, $b1); + }, + { + actual_ok => 1, + diag => '', + }, + "circular double set eq" + ); + + $b1->add('b', 'b'); + push(@$v1, 'c', 'c'); + check_test( + sub { + cmp_deeply($v1, $b1); + }, + { + actual_ok => 0, + diag => < 1, + }, + "cmp_set eq" + ); + + check_test( + sub { + cmp_set([1, 2, 2, 3], [1, 1, 2]); + }, + { + actual_ok => 0, + }, + "cmp_set not eq" + ); +} + +{ + my $a1 = \"a"; + my $b1 = \"b"; + my $a2 = \"a"; + my $b2 = \"b"; + + TODO: + { + todo_skip( + "Because I want to get it out the door see notes on bags and sets", + 5 + ); + check_test( + sub { + cmp_deeply([[\'a', \'b']], set(set($a2, $b1), set($b2, $a1))) + }, + { + actual_ok => 1, + diag => "", + }, + "set compare()" + ); + } + + check_test( + sub { + cmp_deeply(['a', 'b', 'c', 'a'], supersetof('b', 'a', 'b')); + }, + { + actual_ok => 1, + diag => "", + }, + "supersetof yes" + ); + + check_test( + sub { + cmp_deeply(['a', 'b', 'c', 'a'], supersetof('d', 'b', 'd')); + }, + { + actual_ok => 0, + diag => <<'EOM', +Comparing $data as a SuperSet +Missing: 'd' +EOM + }, + "supersetof no" + ); + + check_test( + sub { + cmp_deeply(['b', 'a', 'b'], subsetof('a', 'b', 'c', 'a')); + }, + { + actual_ok => 1, + diag => "", + }, + "subsetof yes" + ); + + check_test( + sub { + cmp_deeply(['d', 'b', 'd'], subsetof('a', 'b', 'c', 'a')); + }, + { + actual_ok => 0, + diag => <<'EOM', +Comparing $data as a SubSet +Extra: 'd' +EOM + }, + "subsetof no" + ); +} + +{ + check_test( + sub { + cmp_deeply(['a', 'b', 'c'], noneof('d', 'e', 'f')); + }, + { + actual_ok => 1, + diag => "", + }, + "noneof yes" + ); + + check_test( + sub { + cmp_deeply(['a', 'b', 'c'], noneof('b', 'c', 'd', 'e')); + }, + { + actual_ok => 0, + diag => <<'EOM', +Comparing $data as a NoneOf +Extra: 'b', 'c' +EOM + }, + "noneof no" + ); +} + +{ + check_test( + sub { + cmp_deeply([1, undef, undef], set(undef, 1, undef)); + }, + { + actual_ok => 1, + diag => "", + }, + "undef warnings" + ); + + check_test( + sub { + cmp_deeply([1, undef], set(1)); + }, + { + actual_ok => 0, + diag => < 1, + diag => "", + }, + "shallow eq" + ); + + my $b = []; + check_test( + sub { + cmp_deeply([$a, ["b"]], [shallow($b), ["b"]]); + }, + { + actual_ok => 0, + diag => <[0] + got : $a +expect : $b +EOM + }, + "shallow not eq" + ); + + check_test( + sub { + cmp_deeply([$a."", ["b"]], [shallow($a), ["b"]]); + }, + { + actual_ok => 0, + diag => <[0] + got : '$a' +expect : $a +EOM + }, + "shallow not eq" + ); + + check_test( + sub { + cmp_deeply([$a, ["b"]], [shallow($a), ["a"]]); + }, + { + actual_ok => 0, + diag => <[1][0] + got : 'b' +expect : 'a' +EOM + }, + "deep after shallow not eq" + ); +} + +{ + my $u = shallow(undef); + check_tests( + sub { + cmp_deeply(undef, $u); + cmp_deeply("a", $u); + cmp_deeply("a", $u); + cmp_deeply("a", undef); + }, + [ + { + actual_ok => 1, + }, + { + actual_ok => 0, + }, + { + actual_ok => 0, + }, + { + actual_ok => 0, + }, + ], + "deep after shallow not eq" + ); +} diff --git a/t/string.t b/t/string.t new file mode 100644 index 0000000..fa7b2a5 --- /dev/null +++ b/t/string.t @@ -0,0 +1,65 @@ +use strict; +use warnings; +use lib 't/lib'; + +use Std; + +{ + check_test( + sub { + cmp_deeply("wine", str("wine")) + }, + { + actual_ok => 1, + diag => "", + }, + "string eq" + ); + + check_test( + sub { + cmp_deeply("wine", str("wind")) + }, + { + actual_ok => 0, + diag => <new("wine"); + + check_test( + sub { + cmp_deeply($o, str("wine")) + }, + { + actual_ok => 1, + diag => "", + }, + "over string eq" + ); + + check_test( + sub { + cmp_deeply($o, str("wind")) + }, + { + actual_ok => 0, + diag => <