The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Test::More;
use strict; use warnings FATAL => 'all';

use List::Objects::WithUtils 'hash';

my $hr = hash();
ok( $hr->does('List::Objects::WithUtils::Role::Hash'),
  'hash obj does role'
);

## array_type()
cmp_ok( $hr->array_type, 'eq', 'List::Objects::WithUtils::Array',
  'array_type() ok'
);

## is_empty()
ok( $hr->is_empty, 'is_empty() ok' );


$hr = hash(foo => 'bar', baz => undef);

## exists()
ok( $hr->exists('foo'), 'key foo exists ok' );
ok( !$hr->exists('pie'), 'key pie nonexistant' );

## defined()
ok( $hr->defined('foo'), 'key foo defined ok');
ok( !$hr->defined('baz'), 'key baz not defined' );

## get()
cmp_ok( $hr->get('foo'), 'eq', 'bar', 'get() ok' );

## copy()
my $copy = $hr->copy;
cmp_ok( $copy->get('foo'), 'eq', 'bar', 'get() on copy ok' );

## sliced()
my $slicable = hash(a => 1, b => 2, c => 3, d => 4);
my $slice = $slicable->sliced('a', 'c', 'z');
isa_ok( $slice, 'List::Objects::WithUtils::Hash',
  'sliced() produced obj'
);
cmp_ok( $slice->keys->count, '==', 2, 'sliced() key count ok' );
ok( !$slice->exists('z'), 'sliced exists(z) ok' );
ok( !$slice->get('b'), 'sliced get(b) ok' );
cmp_ok( $slice->get('a'), '==', 1, 'sliced get(a) ok' );
cmp_ok( $slice->get('c'), '==', 3, 'sliced get(c) ok' );

## keys()
ok(
  ( $hr->keys->grep(sub { $_[0] eq 'foo' })
  && $hr->keys->grep(sub { $_[0] eq 'baz' }) ),
  'keys() ok'
);

## values()
ok(
  ( $hr->values->grep(sub { defined $_[0] and $_[0] eq 'bar' })
  && $hr->values->grep(sub { ! defined($_[0]) }) ),
  'values() ok'
);

## kv()
my $kv = $hr->kv;
my @sorted = $kv->sort_by(sub { $_->[0] })->all;
is_deeply( \@sorted,
  [
    [ baz => undef ],
    [ foo => 'bar' ],
  ],
  'kv() ok'
);

## export()
is_deeply( +{ $hr->export }, +{ foo => 'bar', baz => undef }, 
  'export() ok'
);

## set()
ok $hr->set(snacks => 'tasty') == $hr, 'set() returned self';
cmp_ok( $hr->get('snacks'), 'eq', 'tasty', 'get() after set() ok' );


$hr = hash();

## set(), multi-key
ok( 
  $hr->set(
    a => 1,
    b => 2,
    c => 3,
  ),
  'set multi-key ok'
);
for my $expected (qw/a b c/) {
  ok( 
    $hr->keys->grep(sub { $_[0] eq $expected }),
    "multikey set array has $expected"
  );
}

## get(), multi-key
my $arrget;
ok( $arrget = $hr->get('b', 'c'), 'get multi-key ok' );
for my $expected (qw/B C/) {
  ok(
    $arrget->grep(sub { $_[0] eq $expected }),
    "multikey get array has $expected"
  );
}

## delete()
ok( $hr->set(things => 'stuff'), 'set things ok' );
ok( $hr->delete('things'), 'delete() ok' );
ok( !$hr->get('things'), 'item was deleted' );

## delete(), multi-key
my $deleted;
ok( $deleted = $hr->delete('b', 'c'), 'multikey delete ok' );
cmp_ok( $deleted->count, '==', 2, 'correct number of elements deleted' );

## clear()
$hr->clear;
ok( $hr->is_empty, 'is_empty after clear' );

{ package My::List;
  use strict; use warnings FATAL => 'all';

  require List::Objects::WithUtils::Hash;
  use parent 'List::Objects::WithUtils::Hash';

  package My::Foo;
  use strict; use warnings FATAL => 'all';
  use Test::More;

  my $foo = My::List->new(foo => 1, bar => 2, baz => 3);
  isa_ok( $foo->sliced('foo', 'baz'), 'My::List', 'subclassed obj' );
}

## inflate()
my $obj = hash(foo => 'bar', baz => 'quux')->inflate;
ok $obj->foo eq 'bar', 'accessor on inflated obj ok';
ok $obj->baz eq 'quux', 'accessor on inflated obj ok';
my $cref;
ok ref ($cref = $obj->can('foo')) eq 'CODE', 'can() on inflated obj ok';
ok $obj->$cref eq 'bar', 'can() coderef ok';
ok !$obj->can('cake'), 'negative can() ok';
{ local $@;
  eval {; $obj->set };
  ok $@, 'nonexistant key dies ok';
}
{ local $@;
  eval {; $obj->foo('bar') };
  ok $@, 'read-only dies ok';
}
my %deflated = $obj->DEFLATE;
ok $deflated{foo} eq 'bar', 'deflated HASH looks ok';

my $rwobj = hash(foo => 1, baz => 2)->inflate(rw => 1);
ok $rwobj->foo == 1, 'rw inflated obj accessor read ok';
ok $rwobj->foo('bar') eq 'bar', 'rw inflated obj accessor write ok';
ok $rwobj->foo eq 'bar', 'rw inflated obj accessor rw ok';

done_testing;