#!/usr/bin/perl use Test::More tests=>42; use strict; use lib 'lib'; use base 'Fry::List'; my $list = {}; use lib 't/testlib'; #use Test::Warn; #use Data::Dumper; use MyWarn; #test data; my $bart = {qw/id bart a b status son age 10/}; my $bart2 = {qw/id bart a B status son/}; my $lisa = {qw/id lisa a l status daughter/}; my $lisa2 = {qw/id lisa a L status daughter/}; my $maggie = {qw/id maggie/,a=>[qw/m baby ma/]}; #setup; my $cls = __PACKAGE__; eval { $cls->list }; ok($@,'&list dies if not subclassed'); *list = sub {$list}; sub defaultSet { shift->setMany('age',@_) } #&new $cls->new(%$bart); $cls->new(%$lisa); #td: one of these causing make test to fail #warn_count( sub {$cls->new(qw/not complete/)},qw/new/); #warn_count(sub {$cls->new(qw/id lisa/) },qw/new/); #new internals #&setHashDefault #n: could also test &setHashDefaults $cls->setHashDefault($bart,{qw/friend Milhouse/}); is($bart->{friend},'Milhouse','&setHashDefault: sets default'); delete $bart->{friend}; $cls->setHashDefault($bart,{qw/status bunny/}); is($bart->{status},'son','&setHashDefaults: doesn\'t override'); *_hash_default = sub { return {qw/dog chalupo/} }; my $simple = {qw/id ro/}; $cls->setHashDefault($simple); is_deeply($simple,{qw/id ro dog chalupo/},'&setHashDefaults: _hash_default'); *_hash_default = sub {}; my $nonid = {qw/name Marge status mother/}; $cls->setId(marge=>$nonid); is($nonid->{id},'marge','&setId'); $cls->manyNew(bart2=>$bart2,lisa2=>$lisa2); is_deeply([$cls->getObj(qw/lisa2 bart2/)],[$lisa2,$bart2],'&manyNew'); $cls->unloadObj(qw/bart2 lisa2/); #object operations is_deeply($cls->_obj('bart'),$bart,'&_obj retrieve'); $cls->_obj(lisa=>$lisa2); is_deeply($cls->_obj('lisa'),$lisa2,'&_obj set'); $cls->_obj(lisa=>$lisa); $cls->new(qw/id blah/); $cls->unloadObj('blah'); warn_count (sub {$cls->objExists('blah')},'objExists',0, {msg=>'&unloadObj + &objExists warning: no object '}); is($cls->objExists('lisa'),1,'&objExists'); #getObj is_deeply([$cls->getObj(qw/lisa bart dumbo/)],[$lisa,$bart],'&getObj'); #setObj $cls->setObj(lisa=>$lisa2,bart=>$bart2); is_deeply([$cls->_obj('bart'),$cls->_obj('lisa')],[$bart2,$lisa2],'&setObj'); $cls->setObj(lisa=>$lisa,bart=>$bart); #attribute operations is($cls->get(qw/bart status/),'son','&get: normal'); is($cls->get(qw/bart coolness/),undef,'&get: returns undef on fail'); #warning_like {$cls->get(qw/bart coolness/) } qr//, '&get warning: nonexistant attribute'; warn_count( sub {$cls->get(qw/bart coolness/) },qw/get 0/); is($cls->attrExists(qw/bart coolness/),0,'&attrExists: returns 0 if not found'); #warning_like {$cls->attrExists(qw/bart coolness/) } '', '&attrExists: no warning'; warn_count(sub {$cls->attrExists(qw/bart coolness/) },qw/attrExists 0/);#, '&attrExists: no warning'; $cls->set(qw/bart status punk/); is($cls->get(qw/bart status/),'punk','&set'); #warning_like {$cls->set(qw/bart status/)} qr//,'&set warning: not enough arguments'; warn_count(sub {$cls->set(qw/bart status/)},'set');#'&set warning: not enough arguments'; #warning_like {$cls->getMany(qw/a bart blah lisa/)} [qr//,qr//],'&getMany warning: undef passed'; warn_count( sub {$cls->getMany(qw/a bart blah lisa/)} ,'getMany'); is_deeply([$cls->getMany(qw/a bart blah lisa/)],['b',undef,'l'],'&getMany: invalid id returns undef'); #setMany #warning_like { $cls->setMany('a',qw/bart B lisa L bozo boz/) } [qr//,qr//], #'&setMany warning: invalid id'; warn_count( sub { $cls->setMany('a',qw/bart B lisa L bozo boz/) },'setMany'); is_deeply([$cls->getMany(qw/a bart lisa/)],[qw/B L/],'&setMany'); $cls->setMany('a',qw/bart b lisa l/); #other is_deeply([$cls->findIds(qw/id = bart/)],['bart'],'&findIds: ='); is_deeply([$cls->findIds(qw/age > 8/)],['bart'],'&findIds: >'); is_deeply([$cls->findIds(qw/age < 8/)],[],'&findIds: <'); is_deeply([ sort $cls->findIds(qw/id ~ a/)],[qw/bart lisa/],'&findIds: ~'); #warnings_like {$cls->findIds(qw/id ~/)} qr//,'&findIds warning: not enough arguments'; warn_count ( sub {$cls->findIds(qw/id ~/)},'findIds'); is_deeply([sort $cls->listIds],[qw/bart lisa/],'&listIds'); is_deeply([sort $cls->listAlias],[qw/b l/],'&listAlias'); is_deeply([sort $cls->listAliasAndIds],[qw/b bart l lisa/],'&listAliasAndIds'); is($cls->findAlias('b'),'bart','&findAlias given alias'); is($cls->findAlias('bart'),'bart','&findAlias given id'); is($cls->findAlias('bt'),undef,'&findAlias: invalid id returns undef'); #warning_like {$cls->findAlias('bt') } qr//,'&findAlias warning: invalid id'; warn_count(sub { $cls->findAlias('bt') },'findAlias'); is($cls->anyAlias('bart'),'bart','&anyAlias given id'); #pushArray my @enemies = (qw/skinner nelson/); $cls->pushArray(qw/bart enemies/,@enemies); #warning_like {$cls->pushArray(qw/bart status/,@enemies) } qr//, #'&pushArray warning: invalid attr'; warn_count(sub { $cls->pushArray(qw/bart status/,@enemies) },'pushArray'); is_deeply($cls->get(qw/bart enemies/),\@enemies,'&pushArray'); delete $cls->_obj('bart')->{enemies}; $cls->new(%$maggie); is_deeply([sort $cls->allAttr('a')],[qw/b baby l m ma/],'&allAttr: handles an \@ attribute'); my %args = qw/dad homer son bart/; $cls->convertScalarToHash(\%args,'value'); is_deeply(\%args,{dad=>{value=>'homer'},son=>{value=>'bart'}},'&convertScalarToHash'); #print Dumper $cls->Obj('bart'); $cls->setOrMake(bart=>'blah');#,{force=>1}); #print Dumper $cls->Obj('bart'); is_deeply($cls->get('bart','age'),'blah','&setOrMake: sets'); $cls->setOrMake(bart2=>$bart2,lisa2=>$lisa2); is_deeply([$cls->getObj(qw/lisa2 bart2/)],[$lisa2,$bart2],'&setOrMake: makes'); $cls->unloadObj(qw/bart2 lisa2/); #http://search.cpan.org/src/MSCHWERN/ExtUtils-MakeMaker-6.21/t/lib/ # TieIn and TieOut # t/hints.t has an ok example of its use