From cf05eeb09e4366d7848fb35c1597633f28b4d196 Mon Sep 17 00:00:00 2001
From: doy <doy@tozt.net>
Date: Mon, 12 Jan 2009 22:32:51 -0500
Subject: add a test file for submatching

---
 t/004-submatching.t | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 125 insertions(+)
 create mode 100644 t/004-submatching.t

diff --git a/t/004-submatching.t b/t/004-submatching.t
new file mode 100644
index 0000000..3afd436
--- /dev/null
+++ b/t/004-submatching.t
@@ -0,0 +1,125 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 6;
+
+package Bar;
+use Moose;
+with 'MooseX::Role::Matcher';
+
+has [qw/a b c/] => (
+    is       => 'rw',
+    required => 1,
+);
+
+package Baz;
+use Moose;
+with 'MooseX::Role::Matcher';
+
+has [qw/a b c/] => (
+    is       => 'rw',
+    required => 1,
+);
+
+package Foo;
+use Moose;
+with 'MooseX::Role::Matcher';
+
+has bar => (
+    is       => 'ro',
+    isa      => 'Bar',
+    required => 1,
+);
+
+has baz => (
+    is       => 'ro',
+    isa      => 'Baz',
+    required => 1,
+);
+
+has [qw/a b c/] => (
+    is       => 'ro',
+    required => 1,
+);
+
+package main;
+{
+    my $bar = Bar->new(a => 1, b => 2, c => 3);
+    my $baz = Baz->new(a => 'chess', b => 'go', c => 'nethack');
+    my $foo = Foo->new(bar => $bar, baz => $baz,
+                       a => 'foo', b => 'bar', c => 'baz');
+    ok($foo->match(bar => {
+                       a => 1,
+                   }),
+       'simple submatching works');
+    ok($foo->match(bar => {
+                       b    => 2,
+                       '!c' => sub { $_ > 5 },
+                   }),
+       'simple submatching works');
+    ok($foo->match(a => 'foo',
+                   bar => {
+                       b => qr/\d/,
+                       a => sub { length == 1 },
+                   },
+                   baz => {
+                       c => 'nethack',
+                       a => qr/^c.*s$/
+                   },
+       ),
+       'simple submatching works');
+}
+{
+    my $bar = Bar->new(a => 4, b => 5, c => 6);
+    my $baz = Baz->new(a => $bar, b => 'quux', c => 'cribbage');
+    my $foo = Foo->new(a => 3.14, b => 2.72, c => 1.61,
+                       bar => $bar, baz => $baz);
+    ok($foo->match(a   => 3.14,
+                   bar => {
+                       a => 4,
+                   },
+                   baz => {
+                       b => sub { length == 4 },
+                       a => {
+                           b => 5,
+                           c => qr/\d/,
+                       },
+                   }),
+       'deeper submatching works');
+}
+{
+    my $bar = Bar->new(a => 7, b => 'tmp', c => 9);
+    my $baz = Baz->new(a => $bar, b => 'quuux', c => 'tmp');
+    my $foo = Foo->new(a => 256, b => 65536, c => 4294967296,
+                       bar => $bar, baz => $baz);
+    $bar->b($foo);
+    $baz->c($baz);
+    ok($foo->match(baz => {
+                       c => {
+                           c => {
+                               c => {
+                                   c => {
+                                       b => 'quuux',
+                                   },
+                               },
+                           },
+                       },
+                   }),
+       'cyclical submatching works');
+    ok($foo->match('!b' => sub { $_ % 2 },
+                   bar  => {
+                       a => 7,
+                       b => {
+                           a => qr/\d+/,
+                           baz => {
+                               c => {
+                                   a => {
+                                       a => 7,
+                                       b => $foo
+                                   },
+                               },
+                           },
+                       },
+                   }),
+       'cyclical submatching works');
+}
-- 
cgit v1.2.3