#!/usr/bin/perl use warnings; use strict; use lib 't/lib', 'lib'; use Frost::Test; use Test::More tests => 85; #use Test::More 'no_plan'; use_ok 'Frost::Asylum'; BEGIN { { package Frost::Meta::Class; # expensive version !!!!!! use Moose::Role; use Frost::Util; sub is_readonly { $_[0]->_is_feature ( $_[1], 'readonly' ); } sub is_transient { $_[0]->_is_feature ( $_[1], 'transient' ); } sub is_derived { $_[0]->_is_feature ( $_[1], 'derived' ); } sub is_virtual { $_[0]->_is_feature ( $_[1], 'virtual' ); } sub is_index { $_[0]->_is_feature ( $_[1], 'index' ); } sub is_unique { $_[0]->_is_feature ( $_[1], 'unique' ); } sub is_auto_id { $_[0]->_is_feature ( $_[1], 'auto_id' ); } sub is_auto_inc { $_[0]->_is_feature ( $_[1], 'auto_inc' ); } sub _is_feature { my ( $self, $attr_name, $feature ) = @_; my $class = $self->name; my $attr = find_attribute_manuel $class, $attr_name; my $method = 'is_' . $feature; my $result = $attr->$method(); return $result; } no Moose::Role; } } { package Foo; # must exist for type ClassName # Just testing - DON'T TRY THIS AT HOME! # Always say "use Frost"... # use Moose; Moose::Util::MetaRole::apply_metaroles ( for => __PACKAGE__, class_metaroles => { class => [ 'Frost::Meta::Class' ], attribute => [ 'Frost::Meta::Attribute' ], } ); has id => ( isa => 'Int', is => 'ro' ); has _dirty => ( virtual => 1, isa => 'Bool', is => 'ro' ); has lastname => ( index => 1, is => 'rw', isa => 'Str' ); # must exist for attribute check has firstname => ( index => 1, is => 'rw', isa => 'Str' ); # must exist for attribute check has date => ( index => 1, is => 'rw', isa => 'Str' ); # must exist for attribute check no Moose; __PACKAGE__->meta->make_immutable() unless $::MAKE_MUTABLE; } my ( $asylum ); lives_ok { $asylum = Frost::Asylum->new ( classname => 'Foo', data_root => $TMP_PATH ); } 'new asylum'; my ( @a, @a_e ); # from DB_File-1.820/t/db-btree.t # slightly different... # DON'T TRY THIS AT HOME, # use only the API methods below... # # The following stuff will be done by Frost::Locum magi-, automati- and what-ever-cally! # my $data = { 1 => { firstname => 'mickey', lastname => 'mouse', }, 2 => { firstname => 'Larry', lastname => 'Wall', }, 3 => { firstname => 'Stone', lastname => 'Wall', }, # Note the duplicate key 4 => { firstname => 'Brick', lastname => 'Wall', }, # Note the duplicate key 5 => { firstname => 'Brick', lastname => 'Wall', }, # Note the duplicate key and value 6 => { firstname => 'John', lastname => 'Smith', }, }; # prepare test... # foreach my $id ( sort keys %$data ) { for my $slot ( qw( firstname lastname ) ) { is $asylum->_silence ( 'Foo', $id, $slot, $data->{$id}->{$slot} ), true, "_silence Foo $id $slot"; # auto-create of id-spirit } is $asylum->_silence ( 'Foo', $id, '_dirty', true ), true, "_silence Foo $id _dirty manually"; } lives_ok { $asylum->close; } 'asylum saved and closed'; $asylum = undef; # force auto-open and -reload lives_ok { $asylum = Frost::Asylum->new ( data_root => $TMP_PATH ); } 'asylum re-created'; # API methods: # is $asylum->count ( 'Foo', 'Unkown', 'lastname', true ), 0, "illuminator has no entry for Unknown"; is $asylum->count ( 'Foo', 'Smith', 'lastname', true ), 1, "illuminator has 1 entry for Smith"; is $asylum->count ( 'Foo', 'Wall', 'lastname', true ), 4, "illuminator has 4 entries for Wall"; is $asylum->count ( 'Foo' ), 6, 'cemetery has 6 entries'; @a = $asylum->lookup ( 'Foo', 'Unknown', 'lastname' ); @a_e = (); cmp_deeply \@a, bag(@a_e), 'get Unknown'; @a = $asylum->lookup ( 'Foo', 'Smith', 'lastname' ); @a_e = qw( 6 ); cmp_deeply \@a, bag(@a_e), 'get Smith'; @a = $asylum->lookup ( 'Foo', 'Wall', 'lastname' ); @a_e = qw( 2 3 4 5 ); cmp_deeply \@a, bag(@a_e), 'get Wall'; my @param; @param = ( 'Foo', undef, 'lastname' ); @a = $asylum->first ( @param ); @a_e = qw( 6 Smith ); cmp_deeply \@a, bag(@a_e), "first (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 2 Wall ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 3 Wall ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 4 Wall ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 5 Wall ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 1 mouse ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "no next"; @param = ( 'Foo', undef, 'firstname' ); @a = $asylum->first ( @param ); @a_e = qw( 4 Brick ); cmp_deeply \@a, bag(@a_e), "first (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 5 Brick ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 6 John ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 2 Larry ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 3 Stone ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 1 mickey ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "no next"; @param = ( 'Foo', 'Wa', 'lastname' ); @a = $asylum->find ( @param ); @a_e = qw( 2 Wall ); cmp_deeply \@a, bag(@a_e), "find 'Wa' (@a_e)"; @a = $asylum->find_next ( @param ); @a_e = qw( 3 Wall ); cmp_deeply \@a, bag(@a_e), "find_next 'Wa' (@a_e)"; @a = $asylum->find_next ( @param ); @a_e = qw( 4 Wall ); cmp_deeply \@a, bag(@a_e), "find_next 'Wa' (@a_e)"; @a = $asylum->find_next ( @param ); @a_e = qw( 5 Wall ); cmp_deeply \@a, bag(@a_e), "find_next 'Wa' (@a_e)"; @a = $asylum->find_next ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "find_next 'Wa' no next"; @param = ( 'Foo', 'A', 'lastname' ); @a = $asylum->find ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "find 'A' none"; @a = $asylum->find_next ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "find_next 'A' none"; @a = $asylum->match ( @param ); @a_e = qw( 6 Smith ); cmp_deeply \@a, bag(@a_e), "match 'A' (@a_e)"; @a = $asylum->match_next ( @param ); @a_e = qw( 2 Wall ); cmp_deeply \@a, bag(@a_e), "match_next 'A' (@a_e)"; @a = $asylum->match_next ( @param ); @a_e = qw( 3 Wall ); cmp_deeply \@a, bag(@a_e), "match_next 'A' (@a_e)"; @a = $asylum->match_next ( @param ); @a_e = qw( 4 Wall ); cmp_deeply \@a, bag(@a_e), "match_next 'A' (@a_e)"; @a = $asylum->match_next ( @param ); @a_e = qw( 5 Wall ); cmp_deeply \@a, bag(@a_e), "match_next 'A' (@a_e)"; @a = $asylum->match_next ( @param ); @a_e = qw( 1 mouse ); cmp_deeply \@a, bag(@a_e), "match_next 'A' (@a_e)"; @a = $asylum->match_next ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "match_next 'A' no next"; @param = ( 'Foo', 'a', 'lastname' ); @a = $asylum->find ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "find 'a' none"; @a = $asylum->find_next ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "find_next 'a' none"; @a = $asylum->match ( @param ); @a_e = qw( 1 mouse ); cmp_deeply \@a, bag(@a_e), "match 'a' (@a_e)"; @a = $asylum->match_next ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "match_next 'a' none"; lives_ok { $asylum->clear; } 'cleared'; my $dates = { 90630 => { date => '2009-06-30' }, 90711 => { date => '2009-07-11' }, 90712 => { date => '2009-07-12' }, 90810 => { date => '2009-08-10' }, 100710 => { date => '2010-07-10' }, 190710 => { date => '2009-07-10' }, 290710 => { date => '2009-07-10' }, 390710 => { date => '2009-07-10' }, }; # prepare test... # foreach my $id ( sort keys %$dates ) { for my $slot ( qw( date ) ) { is $asylum->_silence ( 'Foo', $id, $slot, $dates->{$id}->{$slot} ), true, "_silence Foo $id $slot"; # auto-create of id-spirit } is $asylum->_silence ( 'Foo', $id, '_dirty', true ), true, "_silence Foo $id _dirty manually"; } #DEBUG Dumper $asylum; lives_ok { $asylum->close; } 'asylum saved and closed'; $asylum = undef; # force auto-open and -reload lives_ok { $asylum = Frost::Asylum->new ( data_root => $TMP_PATH ); } 'asylum re-created'; { # first do a match to find the nearest date # my $start = '2009-07-01'; my @param = ( 'Foo', $start, 'date' ); @a = $asylum->match ( @param ); @a_e = qw( 190710 2009-07-10 ); cmp_deeply \@a, bag(@a_e), "match $start -> (@a_e)"; # get this date and proceed with cursor # my $date = $a[0]; @param = ( 'Foo', $date, 'date' ); @a = $asylum->next ( @param ); @a_e = qw( 290710 2009-07-10 ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = qw( 390710 2009-07-10 ); cmp_deeply \@a, bag(@a_e), "next (@a_e)"; @a = $asylum->next ( @param ); @a_e = (); cmp_deeply \@a, bag(@a_e), "no next"; } { # more date handling # my $from = '2009-07-01'; my $to = '2009-07-31'; my $current = ''; my @ids = (); my @param = ( 'Foo', $from, 'date' ); @a = $asylum->match ( @param ); $current = $a[0]; while ( @a and ( $current le $to ) ) { push @ids, $a[1]; @a = $asylum->next ( 'Foo', undef, 'date' ); $current = $a[0]; } cmp_deeply \@ids, bag ( qw( 90711 90712 190710 290710 390710 ) ), "got all values from $from to $to"; }