From: <chr...@us...> - 2006-06-14 22:21:22
|
Revision: 890 Author: chromatic Date: 2006-06-14 15:21:11 -0700 (Wed, 14 Jun 2006) ViewCVS: http://svn.sourceforge.net/everydevel/?rev=890&view=rev Log Message: ----------- r17845@windwheel: chromatic | 2006-06-14 15:20:57 -0700 Split buildNodetypeModules() between Everything::DB and Everything::NodeBase. Revised tests for new version. Modified Paths: -------------- trunk/ebase/lib/Everything/DB.pm trunk/ebase/lib/Everything/NodeBase.pm trunk/ebase/lib/Everything/Test/NodeBase.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17843 + a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17845 Modified: trunk/ebase/lib/Everything/DB.pm =================================================================== --- trunk/ebase/lib/Everything/DB.pm 2006-06-14 21:17:13 UTC (rev 889) +++ trunk/ebase/lib/Everything/DB.pm 2006-06-14 22:21:11 UTC (rev 890) @@ -20,33 +20,28 @@ bless \%args, $class; } -=head2 C<buildNodetypeModules> +=head2 C<fetch_all_nodetype_names()> -Perl 5.6 throws errors if we test "can" on a non-existing module. This -function builds a hashref with keys to all of the modules that exist in the -Everything::Node:: dir This also casts "use" on the modules, loading them into -memory +This method returns a list of the names of all nodetypes in the system. =cut -sub buildNodetypeModules +sub fetch_all_nodetype_names { - my ($this) = @_; + my $self = shift; + my $csr = $self->sqlSelectMany( 'title', 'node', 'type_nodetype=1' ); - my $csr = $this->sqlSelectMany( 'title', 'node', 'type_nodetype=1' ); return unless $csr; - my %modules; + my @modules; while ( my ($title) = $csr->fetchrow_array() ) { $title =~ s/\W//g; - my $modname = "Everything::Node::$title"; - - $modules{$modname} = 1 if $this->loadNodetypeModule($modname); + push @modules, $title; } - return \%modules; + return @modules; } =head2 C<getDatabaseHandle> Modified: trunk/ebase/lib/Everything/NodeBase.pm =================================================================== --- trunk/ebase/lib/Everything/NodeBase.pm 2006-06-14 21:17:13 UTC (rev 889) +++ trunk/ebase/lib/Everything/NodeBase.pm 2006-06-14 22:21:11 UTC (rev 890) @@ -23,7 +23,7 @@ BEGIN { my @methlist = qw( - buildNodetypeModules getDatabaseHandle sqlDelete sqlSelect sqlSelectJoined + getDatabaseHandle sqlDelete sqlSelect sqlSelectJoined sqlSelectMany sqlSelectHashref sqlUpdate sqlInsert _quoteData sqlExecute getNodeByIdNew getNodeByName constructNode selectNodeWhere getNodeCursor countNodeMatches getAllTypes dropNodeTable quote genWhereString @@ -87,7 +87,7 @@ $this->{storage} = $storage_class->new( cache => $this->{cache} ); $this->{storage}->databaseConnect( $dbname, $host, $user, $pass ); - $this->{nodetypeModules} = $this->{storage}->buildNodetypeModules(); + $this->{nodetypeModules} = $this->buildNodetypeModules(); if ( $this->getType('setting') ) { @@ -137,6 +137,30 @@ $this->joinWorkspace( $WORKSPACE ); } +=head2 C<buildNodetypeModules> + +Perl 5.6 throws errors if we test "can" on a non-existing module. This +function builds a hashref with keys to all of the modules that exist in the +Everything::Node:: dir This also casts "use" on the modules, loading them into +memory + +=cut + +sub buildNodetypeModules +{ + my $self = shift; + + my %modules; + + for my $nodetype ( $self->{storage}->fetch_all_nodetype_names() ) + { + my $module = "Everything::Node::$nodetype"; + $modules{ $module } = 1 if $self->loadNodetypeModule( $module ); + } + + return \%modules; +} + =head2 C<rebuildNodetypeModules> Call this to account for any new nodetypes that may have been installed. Modified: trunk/ebase/lib/Everything/Test/NodeBase.pm =================================================================== --- trunk/ebase/lib/Everything/Test/NodeBase.pm 2006-06-14 21:17:13 UTC (rev 889) +++ trunk/ebase/lib/Everything/Test/NodeBase.pm 2006-06-14 22:21:11 UTC (rev 890) @@ -49,7 +49,8 @@ my $module = $self->module_class(); my $mock_db = Test::MockObject->new(); - $mock_db->set_false(qw( getNodeByIdNew getNodeByName )) + $mock_db->set_false(qw( getNodeByIdNew getNodeByName + -fetch_all_nodetype_names )) ->set_true(qw( databaseConnect buildNodetypeModules )) ->fake_module( 'Everything::DB::fake_db', 'new', sub { $mock_db }); @@ -60,7 +61,7 @@ BEGIN { for my $method (qw( - buildNodetypeModules getDatabaseHandle sqlDelete sqlSelect + getDatabaseHandle sqlDelete sqlSelect sqlSelectJoined sqlSelectMany sqlSelectHashref sqlUpdate sqlInsert _quoteData sqlExecute getNodeByIdNew getNodeByName constructNode selectNodeWhere getNodeCursor countNodeMatches getAllTypes @@ -121,6 +122,26 @@ '... reblessing into workspace package' ); } +sub test_build_nodetype_modules :Test( 2 ) +{ + my $self = shift; + my $nb = $self->{nb}; + my $storage = $self->{storage}; + + $nb->set_series( loadNodetypeModule => 1, 1, 0, 1 ); + $storage->mock( + fetch_all_nodetype_names => sub { qw( node nodetype cow dbtable ) } + ); + + my $result = $nb->buildNodetypeModules(); + is( keys %$result, 3, 'buildNodetypeModules() should return a hash ref' ); + is_deeply( + $result, + { map { 'Everything::Node::' . $_ => 1 } qw( node nodetype dbtable ) }, + '... for all loadable nodes fetched from storage engine' + ); +} + sub test_rebuild_nodetype_modules :Test( 1 ) { my $self = shift; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <chr...@us...> - 2006-06-14 22:51:34
|
Revision: 891 Author: chromatic Date: 2006-06-14 15:51:20 -0700 (Wed, 14 Jun 2006) ViewCVS: http://svn.sourceforge.net/everydevel/?rev=891&view=rev Log Message: ----------- r17847@windwheel: chromatic | 2006-06-14 15:51:03 -0700 Moved more database-related methods around to get SQLite working. Added basic tests for Everything::DB. They don't run yet, but they will. Modified Paths: -------------- trunk/ebase/MANIFEST trunk/ebase/lib/Everything/DB.pm trunk/ebase/lib/Everything/Node/nodetype.pm trunk/ebase/lib/Everything/Node.pm trunk/ebase/lib/Everything/NodeBase.pm trunk/ebase/lib/Everything/Test/NodeBase.pm Added Paths: ----------- trunk/ebase/lib/Everything/Test/DB.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17845 + a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17847 Modified: trunk/ebase/MANIFEST =================================================================== --- trunk/ebase/MANIFEST 2006-06-14 22:21:11 UTC (rev 890) +++ trunk/ebase/MANIFEST 2006-06-14 22:51:20 UTC (rev 891) @@ -124,6 +124,7 @@ lib/Everything/NodeBase/Workspace.pm lib/Everything/NodeCache.pm lib/Everything/Security.pm +lib/Everything/Test/DB.pm lib/Everything/Test/NodeBase.pm lib/Everything/Test/NodeBase/Workspace.pm lib/Everything/Util.pm Modified: trunk/ebase/lib/Everything/DB.pm =================================================================== --- trunk/ebase/lib/Everything/DB.pm 2006-06-14 22:21:11 UTC (rev 890) +++ trunk/ebase/lib/Everything/DB.pm 2006-06-14 22:51:20 UTC (rev 891) @@ -13,10 +13,12 @@ use warnings; use DBI; +use Scalar::Util 'weaken'; sub new { my ($class, %args) = @_; + weaken( $args{nb} ); bless \%args, $class; } @@ -520,7 +522,7 @@ return unless ($TYPE); - $this->getRef($TYPE); + $this->{nb}->getRef($TYPE); $NODE = $this->{cache}->getCachedNodeByName( $node, $$TYPE{title} ); return $NODE if ( defined $NODE ); @@ -862,6 +864,57 @@ return @allTypes; } +=head2 C<getNodetypeTables> + +Returns an array of all the tables that a given nodetype joins on. +This will create the array, if it has not already created it. + +=over 4 + +=item * TYPE + +The string name or integer Id of the nodetype + +=item * addnode + +if true, add 'node' to list. Defaults to false. + +=back + +Returns a reference to an array that contains the names of the tables to join +on. If the nodetype does not join on any tables, the array is empty. + +=cut + +sub getNodetypeTables +{ + my ( $this, $TYPE, $addNode ) = @_; + my @tablelist; + + return unless $TYPE; + + # We need to short circuit on nodetype and nodemethod, otherwise we + # get inf recursion. + if ( ( $TYPE eq '1' ) or ( ( ref $TYPE ) && ( $TYPE->{node_id} == 1 ) ) ) + { + push @tablelist, 'nodetype'; + } + elsif ( ref $TYPE && $TYPE->{title} eq 'nodemethod' ) + { + push @tablelist, 'nodemethod'; + } + else + { + $this->{nb}->getRef($TYPE); + my $tables = $TYPE->getTableArray(); + push @tablelist, @$tables if $tables; + } + + push @tablelist, 'node' if $addNode; + + return \@tablelist; +} + =head2 C<dropNodeTable> Drop (delete) a table from the database. Note!!! This is permanent! You will Modified: trunk/ebase/lib/Everything/Node/nodetype.pm =================================================================== --- trunk/ebase/lib/Everything/Node/nodetype.pm 2006-06-14 22:21:11 UTC (rev 890) +++ trunk/ebase/lib/Everything/Node/nodetype.pm 2006-06-14 22:51:20 UTC (rev 891) @@ -109,6 +109,7 @@ Everything::logErrors("Missing '$field'") unless defined $this->{$field}; + $PARENT->{$field} ||= ''; if ( $this->{$field} eq '-1' ) { $this->{$field} = $PARENT->{$field}; Modified: trunk/ebase/lib/Everything/Node.pm =================================================================== --- trunk/ebase/lib/Everything/Node.pm 2006-06-14 22:21:11 UTC (rev 890) +++ trunk/ebase/lib/Everything/Node.pm 2006-06-14 22:51:20 UTC (rev 891) @@ -296,7 +296,6 @@ =cut - =head2 C<assignType> This is an "private" function that should never be needed to be called from @@ -317,6 +316,8 @@ { $$this{type} = $$this{DB}->getType( $$this{type_nodetype} ); } + + bless $this, 'Everything::Node::'. $this->{type}->{title}; } =cut Modified: trunk/ebase/lib/Everything/NodeBase.pm =================================================================== --- trunk/ebase/lib/Everything/NodeBase.pm 2006-06-14 22:21:11 UTC (rev 890) +++ trunk/ebase/lib/Everything/NodeBase.pm 2006-06-14 22:51:20 UTC (rev 891) @@ -84,7 +84,10 @@ $this->{staticNodetypes} = $staticNodetypes ? 1 : 0; my $storage_class = 'Everything::DB::' . $storage; - $this->{storage} = $storage_class->new( cache => $this->{cache} ); + $this->{storage} = $storage_class->new( + nb => $this, + cache => $this->{cache} + ); $this->{storage}->databaseConnect( $dbname, $host, $user, $pass ); $this->{nodetypeModules} = $this->buildNodetypeModules(); @@ -524,57 +527,6 @@ These methods are private. Don't call them. They won't call you. -=head2 C<getNodetypeTables> - -Returns an array of all the tables that a given nodetype joins on. -This will create the array, if it has not already created it. - -=over 4 - -=item * TYPE - -The string name or integer Id of the nodetype - -=item * addnode - -if true, add 'node' to list. Defaults to false. - -=back - -Returns a reference to an array that contains the names of the tables to join -on. If the nodetype does not join on any tables, the array is empty. - -=cut - -sub getNodetypeTables -{ - my ( $this, $TYPE, $addNode ) = @_; - my @tablelist; - - return unless $TYPE; - - # We need to short circuit on nodetype and nodemethod, otherwise we - # get inf recursion. - if ( ( $TYPE eq '1' ) or ( ( ref $TYPE ) && ( $TYPE->{node_id} == 1 ) ) ) - { - push @tablelist, 'nodetype'; - } - elsif ( ref $TYPE && $TYPE->{title} eq 'nodemethod' ) - { - push @tablelist, 'nodemethod'; - } - else - { - $this->getRef($TYPE); - my $tables = $TYPE->getTableArray(); - push @tablelist, @$tables if $tables; - } - - push @tablelist, 'node' if $addNode; - - return \@tablelist; -} - =head2 C<getRef> This makes sure that we have an array of node hashes, not node ids. Added: trunk/ebase/lib/Everything/Test/DB.pm =================================================================== --- trunk/ebase/lib/Everything/Test/DB.pm (rev 0) +++ trunk/ebase/lib/Everything/Test/DB.pm 2006-06-14 22:51:20 UTC (rev 891) @@ -0,0 +1,31 @@ +sub test_get_nodetype_tables :Test( 7 ) +{ + my $self = shift; + my $nb = $self->{nb}; + my $storage = $self->{storage}; + + ok( ! $nb->getNodetypeTables(), + 'getNodetypeTables() should return false without type' ); + + is_deeply( $nb->getNodetypeTables( 1 ), [ 'nodetype' ], + '... and should return nodetype given nodetype id' ); + + is_deeply( $nb->getNodetypeTables( { node_id => 1 } ), [ 'nodetype' ], + '... or nodetype node' ); + + is_deeply( $nb->getNodetypeTables( { title => 'nodemethod', node_id => 0 }), + [ 'nodemethod' ], + '... or should return nodemethod if given nodemethod node' ); + + $nb->mock( getRef => sub { $_[1] = $storage } ); + $storage->set_series( getTableArray => [qw( foo bar )] ); + + is_deeply( $nb->getNodetypeTables( 'bar' ), [qw( foo bar )], + '... or calling getTableArray() on promoted node' ); + + is_deeply( $nb->getNodetypeTables( 'baz' ), [], + '... returning nothing if there are no nodetype tables' ); + + is_deeply( $nb->getNodetypeTables( 'flaz', 1 ), [ 'node' ], + '... but adding node if addNode flag is true' ); +} Property changes on: trunk/ebase/lib/Everything/Test/DB.pm ___________________________________________________________________ Name: svn:mime-type + text/plain; charset=UTF-8 Name: svn:eol-style + native Modified: trunk/ebase/lib/Everything/Test/NodeBase.pm =================================================================== --- trunk/ebase/lib/Everything/Test/NodeBase.pm 2006-06-14 22:21:11 UTC (rev 890) +++ trunk/ebase/lib/Everything/Test/NodeBase.pm 2006-06-14 22:51:20 UTC (rev 891) @@ -350,6 +350,8 @@ is( join( '-', @$args ), "$nb-table-0", '... passing table name' ); } +=cut + sub test_get_nodetype_tables :Test( 7 ) { my $self = shift; @@ -382,6 +384,8 @@ '... but adding node if addNode flag is true' ); } +=cut + sub test_get_ref :Test( 5 ) { my $self = shift; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <chr...@us...> - 2006-06-21 01:11:13
|
Revision: 892 Author: chromatic Date: 2006-06-20 18:10:58 -0700 (Tue, 20 Jun 2006) ViewCVS: http://svn.sourceforge.net/everydevel/?rev=892&view=rev Log Message: ----------- r17930@windwheel: chromatic | 2006-06-20 18:10:43 -0700 Run the insert() tests for node against a SQLite database. Minor fixes to Everything::NodeBase and Everything::DB::sqlite. Added t/lib/build_test_db.pm to build the test SQLite database. Modified Paths: -------------- trunk/ebase/MANIFEST trunk/ebase/lib/Everything/DB/sqlite.pm trunk/ebase/lib/Everything/Node/Test/htmlpage.pm trunk/ebase/lib/Everything/Node/Test/node.pm trunk/ebase/lib/Everything/NodeBase.pm Added Paths: ----------- trunk/ebase/t/lib/build_test_db.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17847 + a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/MANIFEST =================================================================== --- trunk/ebase/MANIFEST 2006-06-14 22:51:20 UTC (rev 891) +++ trunk/ebase/MANIFEST 2006-06-21 01:10:58 UTC (rev 892) @@ -157,6 +157,7 @@ t/HTML/FormObject/TextArea.t t/HTML/FormObject/TextField.t t/HTML/FormObject/TypeMenu.t +t/lib/build_test_db.pm t/lib/FakeDBI.pm t/lib/FakeNode.pm t/lib/FakeNodeBase.pm Modified: trunk/ebase/lib/Everything/DB/sqlite.pm =================================================================== --- trunk/ebase/lib/Everything/DB/sqlite.pm 2006-06-14 22:51:20 UTC (rev 891) +++ trunk/ebase/lib/Everything/DB/sqlite.pm 2006-06-21 01:10:58 UTC (rev 892) @@ -79,7 +79,7 @@ $getHash = 1 unless defined $getHash; $table ||= "node"; - my $DBTABLE = $this->getNode( $table, 'dbtable' ) || {}; + my $DBTABLE = $this->{nb}->getNode( $table, 'dbtable' ) || {}; unless ( exists $DBTABLE->{Fields} ) { @@ -96,6 +96,12 @@ return map { $_->{Field} } @{ $DBTABLE->{Fields} }; } +sub lastValue +{ + my $self = shift; + return $self->{dbh}->func( 'last_insert_rowid' ); +} + =head2 C<tableExists> Check to see if a table of the given name exists in this database. Returns 1 Modified: trunk/ebase/lib/Everything/Node/Test/htmlpage.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/htmlpage.pm 2006-06-14 22:51:20 UTC (rev 891) +++ trunk/ebase/lib/Everything/Node/Test/htmlpage.pm 2006-06-21 01:10:58 UTC (rev 892) @@ -30,7 +30,8 @@ $node->{DB} = $db; delete $node->{parent_container}; - $node->set_true( 'SUPER' ); + $node->set_true( 'SUPER' ) + ->clear(); $db->set_series( -getNode => undef, 'gnc' ); $node->insert( 'user' ); Modified: trunk/ebase/lib/Everything/Node/Test/node.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/node.pm 2006-06-14 22:51:20 UTC (rev 891) +++ trunk/ebase/lib/Everything/Node/Test/node.pm 2006-06-21 01:10:58 UTC (rev 892) @@ -5,12 +5,19 @@ use base 'Test::Class'; +use DBI; use Test::More; use Test::MockObject; use Test::MockObject::Extends; +use File::Copy; +use File::Temp; +use File::Spec::Functions; use Scalar::Util qw( reftype blessed ); +use Everything::NodeBase; +use Everything::DB::sqlite; + sub node_class { my $self = shift; @@ -24,6 +31,8 @@ my $self = shift; $self->{errors} = []; + $self->make_base_test_db(); + my $mock = Test::MockObject->new(); $mock->fake_module( 'Everything', logErrors => sub { @@ -32,12 +41,12 @@ ); *Everything::Node::node::DB = \$mock; - my $module = $self->node_class(); + my $module = $self->node_class(); my %import; my $mockimport = sub { $import{ +shift }++ }; - for my $mod (qw( DBI Everything Everything::NodeBase Everything::XML)) + for my $mod (qw( DBI Everything Everything::XML)) { $mock->fake_module( $mod, import => $mockimport ); } @@ -49,6 +58,28 @@ isa_ok( $module->new(), $module ); } +sub make_base_test_db +{ + my $self = shift; + + my $blank_db = catfile(qw( t ebase.db )); + require 't/lib/build_test_db.pm' unless -e $blank_db; + + my $tempdir = File::Temp::tempdir( DIR => 't', CLEANUP => 1 ); + my $module = $self->node_class(); + my $module_db = catfile( $tempdir, $module . '_base.db' ); + + copy( $blank_db, $module_db ) + or die "No test database for $module $!"; + + $self->{base_test_db} = $module_db; + $self->{tempdir} = $tempdir; + $self->populate_base_database( $module_db ); +} + +# override if necessary +sub populate_base_database {} + sub test_extends :Test( 1 ) { my $self = shift; @@ -70,7 +101,10 @@ sub make_fixture :Test(setup) { my $self = shift; - my $db = Test::MockObject->new(); + $self->make_test_db(); + + my $nb = Everything::NodeBase->new( $self->{test_db}, 1, 'sqlite' ); + my $db = Test::MockObject::Extends->new( $nb ); $self->reset_mock_node(); *Everything::Node::node::DB = \$db; @@ -79,6 +113,21 @@ $self->{errors} = []; } +sub make_test_db +{ + my $self = shift; + my $method_name = $self->current_method(); + my $base_db = $self->{base_test_db}; + my $tempdir = $self->{tempdir}; + my $test_db = catfile( $tempdir, $method_name . '.db' ); + + copy( $base_db, $test_db ) + or die "Cannot create test db for $method_name: $!\n"; + + $self->{test_db} = $test_db; + $self->{test_dbh} = DBI->connect( "dbi:SQLite:dbname=$test_db", '', '' ); +} + sub reset_mock_node { my $self = shift; @@ -155,58 +204,48 @@ '... or should return the inserted node_id otherwise' ); } -sub test_insert :Test( 10 ) +sub test_insert :Test( 3 ) { my $self = shift; my $node = $self->{node}; my $db = $self->{mock_db}; + my $type = $db->getType( 'nodetype' ); + $node->{node_id} = 0; - $node->{type} = $node; - $node->{restrictdupes} = 1; + $node->{type} = $type; + $node->{type_nodetype} = 1; $node->set_true(qw( -hasAccess -restrictTitle -getId )); - $db->set_always( getNode => { key => 'value' } ) - ->set_always( -lastValue => 101 ); $node->{foo} = 11; delete $node->{type}{restrictdupes}; - $db->set_list( -getFields => 'foo' ) - ->set_series( getNode => 0, {} ) - ->set_true( 'sqlInsert' ) - ->set_always( -now => 'now' ) - ->clear(); - $node->set_always( -getTableArray => [ 'table' ] ) - ->set_true( 'cache' ); + my $time = time(); + $db->set_always( -now => $time ); + + $node->set_true( 'cache' ); $node->{node_id} = 0; - ok( defined $node->insert( 'user' ), - '... but should return node_id if no dupes exist' ); - - my ( $method, $args ) = $db->next_call( 2 ); - is( $method, 'sqlInsert', '... inserting base node' ); + my $result = $node->insert( 'user' ); - is( $args->[1], 'node', '... into the node table' ); - is_deeply( $args->[2], + ok( defined $result, 'insert() should return a node_id if no dupes exist' ); + is( $result, 4, '... with the proper sequence' ); + + my $dbh = $db->{storage}->getDatabaseHandle(); + my $sth = $dbh->prepare( + 'SELECT createtime, author_user, hits FROM node WHERE node_id=?' + ); + $sth->execute( $result ); + my $node_ref = $sth->fetchrow_hashref(); + is_deeply( $node_ref, { - -createtime => 'now', + createtime => $time, author_user => 'user', hits => 0, - foo => 11, }, '... with the proper fields' ); - - ( $method, $args ) = $db->next_call(); - is( $method, 'sqlInsert', '... inserting node' ); - is( $args->[1], 'table', '... into proper table' ); - is_deeply( $args->[2], { foo => 11, table_id => 101 }, - '... proper fields' ); - - ( $method, $args ) = $db->next_call(); - is( $method, 'getNode', '... fetching node' ); - is( join( '-', @$args ), "$db-101-force", '... forcing refresh' ); - is( $node->next_call(), 'cache', '... and caching node' ); + $sth->finish(); } sub test_update_access :Test( 3 ) Modified: trunk/ebase/lib/Everything/NodeBase.pm =================================================================== --- trunk/ebase/lib/Everything/NodeBase.pm 2006-06-14 22:51:20 UTC (rev 891) +++ trunk/ebase/lib/Everything/NodeBase.pm 2006-06-21 01:10:58 UTC (rev 892) @@ -23,10 +23,10 @@ BEGIN { my @methlist = qw( - getDatabaseHandle sqlDelete sqlSelect sqlSelectJoined + getDatabaseHandle sqlDelete sqlSelect sqlSelectJoined getFieldsHash sqlSelectMany sqlSelectHashref sqlUpdate sqlInsert _quoteData sqlExecute getNodeByIdNew getNodeByName constructNode selectNodeWhere getNodeCursor - countNodeMatches getAllTypes dropNodeTable quote genWhereString + countNodeMatches getAllTypes dropNodeTable quote genWhereString lastValue ); for my $method (@methlist) Added: trunk/ebase/t/lib/build_test_db.pm =================================================================== --- trunk/ebase/t/lib/build_test_db.pm (rev 0) +++ trunk/ebase/t/lib/build_test_db.pm 2006-06-21 01:10:58 UTC (rev 892) @@ -0,0 +1,90 @@ +#! perl + +# XXX: this file depends on the format of tables/*.sql +# run it through SQL::Translator if and when it changes! + +use strict; +use warnings; + +use DBI; +use File::Spec::Functions 'catfile'; + +my $db_file = catfile(qw( t ebase.db )); +unlink $db_file; + +my $dbh = DBI->connect( "dbi:SQLite:dbname=$db_file", '', '' ); + +my @tables = split /\n--\n/, <<END_TABLES; +CREATE TABLE node ( + node_id INTEGER PRIMARY KEY NOT NULL, + type_nodetype int(11) NOT NULL DEFAULT '0', + title char(240) NOT NULL DEFAULT '', + author_user int(11) NOT NULL DEFAULT '0', + createtime datetime NOT NULL DEFAULT '0000-00-00 00:00:00', + modified datetime NOT NULL DEFAULT '0000-00-00 00:00:00', + hits int(11) DEFAULT '0', + loc_location int(11) DEFAULT '0', + reputation int(11) NOT NULL DEFAULT '0', + lockedby_user int(11) NOT NULL DEFAULT '0', + locktime datetime NOT NULL DEFAULT '0000-00-00 00:00:00', + authoraccess char(4) NOT NULL DEFAULT 'iiii', + groupaccess char(5) NOT NULL DEFAULT 'iiiii', + otheraccess char(5) NOT NULL DEFAULT 'iiiii', + guestaccess char(5) NOT NULL DEFAULT 'iiiii', + dynamicauthor_permission int(11) NOT NULL DEFAULT '-1', + dynamicgroup_permission int(11) NOT NULL DEFAULT '-1', + dynamicother_permission int(11) NOT NULL DEFAULT '-1', + dynamicguest_permission int(11) NOT NULL DEFAULT '-1', + group_usergroup int(11) NOT NULL DEFAULT '-1' +); +-- +CREATE TABLE nodetype ( + nodetype_id INTEGER PRIMARY KEY NOT NULL DEFAULT '0', + restrict_nodetype int(11) DEFAULT '0', + extends_nodetype int(11) DEFAULT '0', + restrictdupes int(11) DEFAULT '0', + sqltable char(255), + grouptable char(40) DEFAULT '', + defaultauthoraccess char(4) NOT NULL DEFAULT 'iiii', + defaultgroupaccess char(5) NOT NULL DEFAULT 'iiiii', + defaultotheraccess char(5) NOT NULL DEFAULT 'iiiii', + defaultguestaccess char(5) NOT NULL DEFAULT 'iiiii', + defaultgroup_usergroup int(11) NOT NULL DEFAULT '-1', + defaultauthor_permission int(11) NOT NULL DEFAULT '-1', + defaultgroup_permission int(11) NOT NULL DEFAULT '-1', + defaultother_permission int(11) NOT NULL DEFAULT '-1', + defaultguest_permission int(11) NOT NULL DEFAULT '-1', + maxrevisions int(11) NOT NULL DEFAULT '-1', + canworkspace int(11) NOT NULL DEFAULT '-1' +); +-- +CREATE TABLE setting ( + setting_id INTEGER PRIMARY KEY NOT NULL DEFAULT '0', + vars text(65535) NOT NULL +); +-- +CREATE TABLE version ( + version_id INTEGER PRIMARY KEY NOT NULL DEFAULT '0', + version int(11) NOT NULL DEFAULT '1' +); +-- +CREATE INDEX title_node on node (title, type_nodetype); +-- +CREATE INDEX author_node on node (author_user); +-- +CREATE INDEX type_node on node (type_nodetype); +END_TABLES + +my $nodes = do { + local $/; local @ARGV = catfile(qw( tables basenodes.in )); <> +}; + +for my $statement (@tables, split /\n/, $nodes ) +{ + next unless $statement =~ /\S/; + $dbh->do( $statement ); +} + +$dbh->disconnect(); + +1; Property changes on: trunk/ebase/t/lib/build_test_db.pm ___________________________________________________________________ Name: svn:mime-type + text/plain; charset=UTF-8 Name: svn:eol-style + native This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-09-12 18:43:15
|
Revision: 908 http://svn.sourceforge.net/everydevel/?rev=908&view=rev Author: paul_the_nomad Date: 2006-09-12 11:42:51 -0700 (Tue, 12 Sep 2006) Log Message: ----------- Unit tests for Util.t, Security.t and NodeCache.t Modified Paths: -------------- trunk/ebase/t/NodeCache.t trunk/ebase/t/Security.t trunk/ebase/t/Util.t Added Paths: ----------- trunk/ebase/lib/Everything/Test/NodeCache.pm trunk/ebase/lib/Everything/Test/Security.pm trunk/ebase/lib/Everything/Test/Util.pm trunk/ebase/lib/Everything/Test.pm trunk/ebase/t/Node/extendednode.t Added: trunk/ebase/lib/Everything/Test/NodeCache.pm =================================================================== --- trunk/ebase/lib/Everything/Test/NodeCache.pm (rev 0) +++ trunk/ebase/lib/Everything/Test/NodeCache.pm 2006-09-12 18:42:51 UTC (rev 908) @@ -0,0 +1,177 @@ +package Everything::Test::NodeCache; + +use Test::More; +use Test::MockObject; +use Scalar::Util qw/blessed/; +use base 'Everything::Test'; +use strict; +use warnings; + + +sub startup :Test(startup => +0) { + my $self = shift; + $self->SUPER; + my $class = $self->{class}; + my $file; + ($file = $class) =~ s/::/\//g; + + $file .= '.pm'; + + require $file; + $class->import; + $self->{mock} = Test::MockObject->new; +} + + +sub test_set_cache_size : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'setCacheSize' ); + +} + +sub test_get_cache_size : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'getCacheSize' ); + +} + +sub test_get_cached_node_by_name : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'getCachedNodeByName' ); +} + +sub test_get_cached_node_by_id : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'getCachedNodeById' ); + +} + +sub test_cache_node : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'cacheNode' ); + +} + +sub test_remove_node : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'removeNode' ); + +} + +sub test_flush_cache : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'flushCache' ); +} + +sub test_flush_cache_global : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'flushCacheGlobal' ); +} + +sub test_dump_cache : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'dumpCache' ); +} + +sub test_purge_cache : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'purgeCache' ); +} + +sub test_remove_node_from_hash : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'removeNodeFromHash' ); +} + +sub test_get_global_version : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'getGlobalVersion' ); +} + +sub test_is_same_version : Test(9) +{ + my $self = shift; + my $package = $self->{class}; + my $mock = $self->{mock}; + can_ok( $package, 'isSameVersion' ); + is( Everything::NodeCache::isSameVersion(), undef, + 'isSameVersion() should return undef without node' ); + + $mock->{version}{12} = 1; + $mock->{verified}{11} = 1; + $mock->{typeVerified}{10} = 1; + + my $node = { + type => { node_id => 10 }, + node_id => 11, + }; + + $node->{type}{node_id} = 11; + ok( Everything::NodeCache::isSameVersion( $mock, $node ), '... true if node type is verified' ); + + $node->{node_id} = 11; + ok( Everything::NodeCache::isSameVersion( $mock, $node ), '... true if node id is verified' ); + + $node->{node_id} = 13; + ok( ! Everything::NodeCache::isSameVersion( $mock, $node ), + '... false unless node version is verified' ); + + $node->{node_id} = 12; + $mock->set_series( getGlobalVersion => undef, 2, 1 ); + ok( ! Everything::NodeCache::isSameVersion( $mock, $node ), + '... false unless node has global version' ); + ok( ! Everything::NodeCache::isSameVersion( $mock, $node ), '... false unless global version matches' ); + ok( Everything::NodeCache::isSameVersion( $mock, $node ), '... true if global version matches' ); + ok( $mock->{verified}{12}, '... setting verified flag' ); + + +} + +sub test_increment_global_version : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'incrementGlobalVersion' ); + +} + +sub test_reset_cache : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'resetCache' ); +} + +sub test_cache_method : Test(1) +{ + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'cacheMethod' ); + +} + +1; Property changes on: trunk/ebase/lib/Everything/Test/NodeCache.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Added: trunk/ebase/lib/Everything/Test/Security.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Security.pm (rev 0) +++ trunk/ebase/lib/Everything/Test/Security.pm 2006-09-12 18:42:51 UTC (rev 908) @@ -0,0 +1,48 @@ +package Everything::Test::Security; + +use base 'Everything::Test'; +use Test::More; + + +sub test_inherit_permissions :Test(6) { + + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'inheritPermissions' ); + is( Everything::Security::inheritPermissions( '----', 'rwxd' ), + '----', + 'inheritPermissions() should not modify uninheritable permissions' ); + is( Everything::Security::inheritPermissions( 'i-i-', 'rwxd' ), + 'r-x-', '... and should inherit the inheritable' ); + + my @le; + local *Everything::logErrors; + *Everything::logErrors = sub { push @le, [@_] }; + + ok( ! Everything::Security::inheritPermissions( '---', '----' ), + '... should fail with permission length mismatch' ); + is( @le, 1, '... logging a warning' ); + like( $le[0][0], qr/permission length mismatch/i, '... and warn about it' ); + +} + +sub test_check_permissions :Test(7) { + + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'checkPermissions' ); + + @le = (); + ok( !Everything::Security::checkPermissions('rwx-'), + 'check() should return false unless modes are passed' ); + is( @le, 0, '... and should not warn' ); + + ok( Everything::Security::checkPermissions( 'rwxd', 'rw' ), + '... should return true if op is permitted' ); + ok( ! Everything::Security::checkPermissions( 'rwxd', 'rwxdc' ), '... and false if op is prohibited' ); + ok( ! Everything::Security::checkPermissions( '', 'r' ), '... and false if no perms are present' ); + ok( ! Everything::Security::checkPermissions( 'i', '' ), '... and false if no modes are present' ); + +} + +1; Property changes on: trunk/ebase/lib/Everything/Test/Security.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Added: trunk/ebase/lib/Everything/Test/Util.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Util.pm (rev 0) +++ trunk/ebase/lib/Everything/Test/Util.pm 2006-09-12 18:42:51 UTC (rev 908) @@ -0,0 +1,46 @@ +package Everything::Test::Util; + +use base 'Everything::Test'; +use Test::More; +use strict; + +sub startup :Test(startup => +0) { + my $self = shift; + $self->SUPER; + my $class = $self->{class}; + my $file; + ($file = $class) =~ s/::/\//g; + + $file .= '.pm'; + + require $file; + $class->import; + +} + +sub test_escape :Test(4){ + + my $self = shift; + can_ok( $self->{class}, 'escape' ); + my $encoded = escape('abc|@# _123'); + $self->{encoded} = $encoded; + like( $encoded, qr/^abc.+_123$/, 'escape() should not modify alphanumerics' ); + my @encs = $encoded =~ m/%([a-fA-F\d]{2})/g; + is( scalar @encs, 4, '... should encode all nonalphanumerics in string' ); + is( join( '', map { chr( hex($_) ) } @encs ), + '|@# ', '... using ord() and hex()' ); + + + +} + +sub test_unescape :Test(2) { + my $self = shift; + my $encoded = $self->{encoded}; + can_ok( $self->{class}, 'unescape' ); + is( unescape($encoded), 'abc|@# _123', 'unescape() should reverse escape()' ); + + +} + +1; Property changes on: trunk/ebase/lib/Everything/Test/Util.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Added: trunk/ebase/lib/Everything/Test.pm =================================================================== --- trunk/ebase/lib/Everything/Test.pm (rev 0) +++ trunk/ebase/lib/Everything/Test.pm 2006-09-12 18:42:51 UTC (rev 908) @@ -0,0 +1,29 @@ +package Everything::Test; + +use Scalar::Util 'blessed'; +use SUPER; +use Test::More; + +use base 'Test::Class'; + + + +sub module_class +{ + my $self = shift; + my $name = blessed( $self ); + $name =~ s/Test:://; + return $name; +} + + +sub startup :Test( startup => 1 ) +{ + my $self = shift; + my $module = $self->module_class(); + use_ok( $module ) or exit; + $self->{class} = $self->module_class; + +} + +1; Property changes on: trunk/ebase/lib/Everything/Test.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Added: trunk/ebase/t/Node/extendednode.t =================================================================== --- trunk/ebase/t/Node/extendednode.t (rev 0) +++ trunk/ebase/t/Node/extendednode.t 2006-09-12 18:42:51 UTC (rev 908) @@ -0,0 +1,4 @@ +#! perl + +use Everything::Node::Test::extendednode; +Everything::Node::Test::extendednode->runtests(); Property changes on: trunk/ebase/t/Node/extendednode.t ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/t/NodeCache.t =================================================================== --- trunk/ebase/t/NodeCache.t 2006-07-20 11:33:52 UTC (rev 907) +++ trunk/ebase/t/NodeCache.t 2006-09-12 18:42:51 UTC (rev 908) @@ -1,84 +1,7 @@ #!/usr/bin/perl -w use strict; +use Everything::Test::NodeCache; -BEGIN -{ - chdir 't' if -d 't'; - unshift @INC, '../blib/lib', 'lib/', '..'; -} +Everything::Test::NodeCache->runtests; -use vars qw( $AUTOLOAD $errors ); - -use Test::MockObject; -use Test::More tests => 25; - -my $package = 'Everything::NodeCache'; - -use_ok($package) or diag "Compile error\n", exit; - -sub AUTOLOAD -{ - return if $AUTOLOAD =~ /DESTROY$/; - - no strict 'refs'; - $AUTOLOAD =~ s/^main:://; - - my $sub = "${package}::$AUTOLOAD"; - if ( defined &{$sub} ) - { - *{$AUTOLOAD} = \&{$sub}; - goto &{$sub}; - } -} - -my $mock = Test::MockObject->new(); - -can_ok( $package, 'isSameVersion' ); -is( isSameVersion(), undef, - 'isSameVersion() should return undef without node' ); - -$mock->{version}{12} = 1; -$mock->{verified}{11} = 1; -$mock->{typeVerified}{10} = 1; - -my $node = { - type => { node_id => 10 }, - node_id => 11, -}; - -$node->{type}{node_id} = 11; -ok( isSameVersion( $mock, $node ), '... true if node type is verified' ); - -$node->{node_id} = 11; -ok( isSameVersion( $mock, $node ), '... true if node id is verified' ); - -$node->{node_id} = 13; -ok( !isSameVersion( $mock, $node ), - '... false unless node version is verified' ); - -$node->{node_id} = 12; -$mock->set_series( getGlobalVersion => undef, 2, 1 ); -ok( !isSameVersion( $mock, $node ), - '... false unless node has global version' ); -ok( !isSameVersion( $mock, $node ), '... false unless global version matches' ); -ok( isSameVersion( $mock, $node ), '... true if global version matches' ); -ok( $mock->{verified}{12}, '... setting verified flag' ); - -#stubbing out possible tests: - -can_ok( $package, 'setCacheSize' ); -can_ok( $package, 'getCacheSize' ); -can_ok( $package, 'cacheNode' ); -can_ok( $package, 'removeNode' ); -can_ok( $package, 'getCachedNodeById' ); -can_ok( $package, 'getCachedNodeByName' ); -can_ok( $package, 'dumpCache' ); -can_ok( $package, 'flushCache' ); -can_ok( $package, 'flushCacheGlobal' ); -can_ok( $package, 'purgeCache' ); -can_ok( $package, 'removeNodeFromHash' ); -can_ok( $package, 'getGlobalVersion' ); -can_ok( $package, 'incrementGlobalVersion' ); -can_ok( $package, 'resetCache' ); -can_ok( $package, 'cacheMethod' ); Modified: trunk/ebase/t/Security.t =================================================================== --- trunk/ebase/t/Security.t 2006-07-20 11:33:52 UTC (rev 907) +++ trunk/ebase/t/Security.t 2006-09-12 18:42:51 UTC (rev 908) @@ -1,63 +1,9 @@ #!/usr/bin/perl -w use strict; -use vars qw( $AUTOLOAD ); +use Everything::Test::Security; -BEGIN -{ - chdir 't' if -d 't'; - use lib '../blib/lib', '..', 'lib/'; -} +Everything::Test::Security->runtests; -use Test::More tests => 14; +exit 0; -my $package = 'Everything::Security'; - -sub AUTOLOAD -{ - return if $AUTOLOAD =~ /DESTROY$/; - - no strict 'refs'; - $AUTOLOAD =~ s/^main:://; - - my $sub = "${package}::$AUTOLOAD"; - - if ( defined &{$sub} ) - { - *{$AUTOLOAD} = \&{$sub}; - goto &{$sub}; - } -} - -use_ok($package); - -# inheritPermissions() -can_ok( $package, 'inheritPermissions' ); -is( inheritPermissions( '----', 'rwxd' ), - '----', - 'inheritPermissions() should not modify uninheritable permissions' ); -is( inheritPermissions( 'i-i-', 'rwxd' ), - 'r-x-', '... and should inherit the inheritable' ); - -my @le; -local *Everything::logErrors; -*Everything::logErrors = sub { push @le, [@_] }; - -ok( !inheritPermissions( '---', '----' ), - '... should fail with permission length mismatch' ); -is( @le, 1, '... logging a warning' ); -like( $le[0][0], qr/permission length mismatch/i, '... and warn about it' ); - -# checkPermissions() -can_ok( $package, 'checkPermissions' ); - -@le = (); -ok( !checkPermissions('rwx-'), - 'check() should return false unless modes are passed' ); -is( @le, 0, '... and should not warn' ); - -ok( checkPermissions( 'rwxd', 'rw' ), - '... should return true if op is permitted' ); -ok( !checkPermissions( 'rwxd', 'rwxdc' ), '... and false if op is prohibited' ); -ok( !checkPermissions( '', 'r' ), '... and false if no perms are present' ); -ok( !checkPermissions( 'i', '' ), '... and false if no modes are present' ); Modified: trunk/ebase/t/Util.t =================================================================== --- trunk/ebase/t/Util.t 2006-07-20 11:33:52 UTC (rev 907) +++ trunk/ebase/t/Util.t 2006-09-12 18:42:51 UTC (rev 908) @@ -1,24 +1,6 @@ #!/usr/bin/perl -w use strict; +use Everything::Test::Util; -BEGIN -{ - chdir 't' if -d 't'; - use lib '../blib/lib', '../lib', '..'; -} - -use Test::More tests => 7; - -use_ok('Everything::Util'); - -can_ok( 'main', 'escape' ); -my $encoded = escape('abc|@# _123'); -like( $encoded, qr/^abc.+_123$/, 'escape() should not modify alphanumerics' ); -my @encs = $encoded =~ m/%([a-fA-F\d]{2})/g; -is( scalar @encs, 4, '... should encode all nonalphanumerics in string' ); -is( join( '', map { chr( hex($_) ) } @encs ), - '|@# ', '... using ord() and hex()' ); - -can_ok( 'main', 'unescape' ); -is( unescape($encoded), 'abc|@# _123', 'unescape() should reverse escape()' ); +Everything::Test::Util->runtests; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-09-13 15:31:52
|
Revision: 909 http://svn.sourceforge.net/everydevel/?rev=909&view=rev Author: paul_the_nomad Date: 2006-09-13 08:27:09 -0700 (Wed, 13 Sep 2006) Log Message: ----------- Unit tests for CacheQueue.pm Modified Paths: -------------- trunk/ebase/t/CacheQueue.t Added Paths: ----------- trunk/ebase/lib/Everything/Test/CacheQueue.pm Added: trunk/ebase/lib/Everything/Test/CacheQueue.pm =================================================================== --- trunk/ebase/lib/Everything/Test/CacheQueue.pm (rev 0) +++ trunk/ebase/lib/Everything/Test/CacheQueue.pm 2006-09-13 15:27:09 UTC (rev 909) @@ -0,0 +1,311 @@ +package Everything::Test::CacheQueue; + +use base 'Everything::Test'; +use Test::More; +use Test::MockObject; +use strict; +use warnings; + +sub startup : Test(startup => +1) { + my $self = shift; + + my $mock = Test::MockObject->new; + my $import; + $mock->fake_module( 'Everything', import => sub { $import = caller } ); + + $self->SUPER; + my $class = $self->{class}; + my $file; + ( $file = $class ) =~ s/::/\//g; + + $file .= '.pm'; + + require $file; + $class->import; + + is( $import, 'Everything::CacheQueue', + 'Everything::CacheQueue should use() Everything' ); + +} + +sub setup : Test(setup) { + my $self = shift; + $self->{mock} = Test::MockObject->new; + +} + +sub test_new : Test(startup => 7) { + my $self = shift; + + local *Everything::CacheQueue::createQueueData; + *Everything::CacheQueue::createQueueData = sub { + return { id => $_[1] }; + }; + + my $cq = Everything::CacheQueue->new(); + isa_ok( $cq, 'Everything::CacheQueue' ); + is( $cq->{queueHead}{id}, 'HEAD', 'new() should create head queue data' ); + is( $cq->{queueTail}{id}, 'TAIL', '... and tail queue data' ); + is( $cq->{queueHead}{prev}{id}, 'TAIL', '... pointing head prev to tail' ); + is( $cq->{queueTail}{next}{id}, 'HEAD', '... and tail next to head' ); + is( $cq->{queueSize}, 0, '... and queueSize should be 0' ); + is( $cq->{numPermanent}, 0, '... and numPermanent should be 0' ); + +} + +sub test_queue_item : Test(4) { + + my $self = shift; + + my $node = $self->{mock}; + $node->set_always( 'createQueueData', ['queued'] ); + $node->mock( + 'queueData', + sub { + my $ref = $_[1]; + $_[1] = join '', @{$ref}; + } + ); + + is( Everything::CacheQueue::queueItem( $node, 'foo', 1 ), + 'queued', 'queueItem() should return queued data' ); + my ( $method, $args ) = $node->next_call; + shift @{$args}; + is( + join( ' ', $method, @{$args} ), + 'createQueueData foo 1', + '... calling createQueueData with item and permanent flag' + ); + + ( $method, $args ) = $node->next_call; + + is( $method, 'queueData', '...calls queueData' ); + is_deeply( $args->[1], ['queued'], '...with correct argument.' ); + +} + +sub test_get_item : Test(3) { + my $self = shift; + + my $node = $self->{mock}; + + my $data = { item => 'foo' }; + $node->set_true( 'removeData', 'queueData' ); + is( Everything::CacheQueue::getItem( $node, $data ), + 'foo', 'getItem() should return cached item' ); + my ( $method, $args ) = $node->next_call; + is( + join( ' ', $method, @{$args}[ 1 .. $#$args ] ), + "removeData $data", + '... removing it from the queue' + ); + ( $method, $args ) = $node->next_call; + is( + join( ' ', $method, @{$args}[ 1 .. $#$args ] ), + "queueData $data", + '... and queueing it again' + ); + +} + +sub test_get_next_item : Test(4) { + + my $self = shift; + my $node = $self->{mock}; + $node->set_true( 'removeData', 'queueData' ); + my $queue = {}; + $queue->{prev} = $node; + $node->{queueHead} = $queue; + $node->{item} = 'foo'; + + is( Everything::CacheQueue::getNextItem($node), + 'foo', 'getNextItem() should return first item in queue' ); + + my ( $method, $args ) = $node->next_call; + is( + join( ' ', $method, @{$args}[ 1 .. $#$args ] ), + "removeData $node", + '... and should call removeData() on item' + ); + + $node->mock( + 'queueData', + sub { + push @{ $_[0]->{_calls} }, ['queueData']; + $_[0]{queueHead}{prev} = { + item => 'bar', + permanent => 0, + }; + } + ); + + $node->{queueHead}{prev}{permanent} = 1; + $node->{_calls} = []; + + is( Everything::CacheQueue::getNextItem($node), + 'bar', '... should skip nodes with permanent flag' ); + + $method = $node->next_call; + $args = $node->next_call; + is( + join( ' ', $method, $args ), + 'removeData queueData', + '... and should requeue permanently cached items' + ); +} + +sub test_get_size : Test(1) { + my $self = shift; + my $node = $self->{mock}; + $node->{queueSize} = 41; + is( Everything::CacheQueue::getSize($node), + 41, 'getSize() should return queue size' ); + +} + +sub test_remove_item : Test(3) { + my $self = shift; + my $node = $self->{mock}; + + $node->set_true('removeData'); + is( Everything::CacheQueue::removeItem($node), + undef, 'removeItem() should return undef if data is undefined' ); + my $data = { item => 'bar' }; + is( Everything::CacheQueue::removeItem( $node, $data ), + 'bar', '... should return queued item' ); + my ( $method, $args ) = $node->next_call; + is( + join( ' ', $method, $args->[1] ), + "removeData $data", + '... and should call removeData() on it' + ); + +} + +sub test_list_items : Test(3) { + my $self = shift; + my $node = $self->{mock}; + $node->{queueTail}{next} = { + item => 'first', + next => { + item => 'second', + next => { item => 'HEAD' } + }, + }; + + my $list = Everything::CacheQueue::listItems($node); + isa_ok( $list, 'ARRAY', 'listItems() should return an array reference' ); + is( scalar @$list, 2, '... of the correct number of items' ); + is( "@$list", 'first second', '... in the correct order (last first)' ); +} + +sub test_queue_data : Test(2) { + my $self = shift; + my $node = $self->{mock}; + $node->set_true('insertData'); + $node->{numPermanent} = 0; + $node->{queueTail} = 'tail'; + my $data = {}; + Everything::CacheQueue::queueData( $node, $data ); + + my ( $method, $args ) = $node->next_call; + is( + join( ' ', $method, @{$args}[ 1 .. $#$args ] ), + "insertData $data tail", + 'queueData() should call insertData() with data and cache tail' + ); + + $data->{permanent} = 1; + Everything::CacheQueue::queueData( $node, $data ); + is( $node->{numPermanent}, 1, + '... and should increment numPermanent only for permanent data' ); + +} + +sub test_insert_data : Test(5) { + my $self = shift; + my $node = $self->{mock}; + my $data = {}; + my $after = { id => 'before next' }; + my $before = { next => $after }; + $node->{queueSize} = 6; + + Everything::CacheQueue::insertData( $node, $data, $before ); + is( $data->{next}{id}, + 'before next', 'insertData() should set data next to before next' ); + is( $data->{prev}, $before, '... and its previous to before' ); + is( $before->{next}, $data, '... and before next to data' ); + is( $after->{prev}, $data, '... and before next prev to data' ); + is( $node->{queueSize}, 7, '... and should increment queueSize' ); +} + +sub test_remove_data : Test(7) { + + my $self = shift; + my $node = $self->{mock}; + + local *removeData = \&Everything::CacheQueue::removeData; + + my $data = { + next => 0, + prev => 0, + }; + + $node->{queueSize} = 0; + is( removeData($node), undef, + 'removeData() should return with nothing in queue' ); + + $node->{queueSize} = 4; + $node->{numPermanent} = 6; + + is( removeData( $node, $data ), + undef, '... or if data has already been removed from queue' ); + + my $next = { prev => 1, }; + + my $prev = { next => 1, }; + + $data = { + next => $next, + prev => $prev, + permanent => 0, + }; + + removeData( $node, $data ); + is( $next->{prev}, $prev, '... should set next prev to previous' ); + is( $prev->{next}, $next, '... should set prev next to next' ); + + is( join( ' ', @$data{qw( next prev )} ), + '0 0', '... and should set next and prev in data to 0' ); + + is( $node->{queueSize}, 3, '... and reduce queueSize' ); + + $data = { + next => $next, + prev => $prev, + permanent => 1, + }; + removeData( $node, $data ); + is( $node->{numPermanent}, 5, + '... but should reduce numPermanent only when removing permanent item' + ); +} + +sub test_create_queue_data : Test(5) { + my $self = shift; + my $node = $self->{mock}; + local *cqd = \&Everything::CacheQueue::createQueueData; + + my $queued = cqd( $node, 'foo' ); + isa_ok( $queued, 'HASH', 'createQueueData() should return a hashref' ); + + is( $queued->{item}, 'foo', '... storing data in "item" slot' ); + is( join( ' ', @$queued{qw( next prev )} ), + '0 0', '... setting "next" and "prev" slots both to 0' ); + is( $queued->{permanent}, 0, '... vivifying "permanent" to 0 if needed' ); + + is( cqd( $node, 'foo', 1 )->{permanent}, + 1, '... but should respect passed "permanent" flag' ); +} + +1; Property changes on: trunk/ebase/lib/Everything/Test/CacheQueue.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/t/CacheQueue.t =================================================================== --- trunk/ebase/t/CacheQueue.t 2006-09-12 18:42:51 UTC (rev 908) +++ trunk/ebase/t/CacheQueue.t 2006-09-13 15:27:09 UTC (rev 909) @@ -1,247 +1,8 @@ #!/usr/bin/perl -w + use strict; +use Everything::Test::CacheQueue; -BEGIN -{ - chdir 't' if -d 't'; - use lib '../blib/lib', 'lib/', '..'; -} +Everything::Test::CacheQueue->runtests; -use Test::More tests => 45; - -use FakeNode; -my $node = FakeNode->new(); - -{ - $INC{'Everything.pm'} = 1; - - my $import; - local *Everything::import; - *Everything::import = sub { - $import = caller(); - }; - use_ok('Everything::CacheQueue'); - is( $import, 'Everything::CacheQueue', - 'Everything::CacheQueue should use() Everything' ); -} - -# new() -{ - local *Everything::CacheQueue::createQueueData; - *Everything::CacheQueue::createQueueData = sub { - return { id => $_[1] }; - }; - - my $cq = Everything::CacheQueue->new(); - isa_ok( $cq, 'Everything::CacheQueue' ); - is( $cq->{queueHead}{id}, 'HEAD', 'new() should create head queue data' ); - is( $cq->{queueTail}{id}, 'TAIL', '... and tail queue data' ); - is( $cq->{queueHead}{prev}{id}, 'TAIL', '... pointing head prev to tail' ); - is( $cq->{queueTail}{next}{id}, 'HEAD', '... and tail next to head' ); - is( $cq->{queueSize}, 0, '... and queueSize should be 0' ); - is( $cq->{numPermanent}, 0, '... and numPermanent should be 0' ); -} - -# queueItem -{ - $node->{_subs}{createQueueData} = ['queued']; - - is( Everything::CacheQueue::queueItem( $node, 'foo', 1 ), - 'queued', 'queueItem() should return queued data' ); - - is( - join( ' ', @{ $node->{_calls}[0] } ), - 'createQueueData foo 1', - '... calling createQueueData with item and permanent flag' - ); - is( - join( ' ', @{ $node->{_calls}[1] } ), - 'queueData queued', - '... and queueData() with item' - ); - -} - -# getItem() -$node->{_calls} = []; -my $data = { item => 'foo' }; -is( Everything::CacheQueue::getItem( $node, $data ), - 'foo', 'getItem() should return cached item' ); -is( - join( ' ', @{ $node->{_calls}[0] } ), - "removeData $data", - '... removing it from the queue' -); -is( - join( ' ', @{ $node->{_calls}[1] } ), - "queueData $data", - '... and queueing it again' -); - -# getNextItem() -{ - my $queue = {}; - $queue->{prev} = $node; - $node->{queueHead} = $queue; - $node->{item} = 'foo'; - - is( Everything::CacheQueue::getNextItem($node), - 'foo', 'getNextItem() should return first item in queue' ); - is( - join( ' ', @{ $node->{_calls}[-1] } ), - "removeData $node", - '... and should call removeData() on item' - ); - - local *FakeNode::queueData; - *FakeNode::queueData = sub { - push @{ $_[0]->{_calls} }, ['queueData']; - $_[0]{queueHead}{prev} = { - item => 'bar', - permanent => 0, - }; - }; - - $node->{queueHead}{prev}{permanent} = 1; - $node->{_calls} = []; - - is( Everything::CacheQueue::getNextItem($node), - 'bar', '... should skip nodes with permanent flag' ); - - is( - join( ' ', $node->{_calls}[0][0], $node->{_calls}[1][0] ), - 'removeData queueData', - '... and should requeue permanently cached items' - ); -} - -# getSize() -$node->{queueSize} = 41; -is( Everything::CacheQueue::getSize($node), - 41, 'getSize() should return queue size' ); - -# removeItem() -is( Everything::CacheQueue::removeItem($node), - undef, 'removeItem() should return undef if data is undefined' ); -$data = { item => 'bar' }; -is( Everything::CacheQueue::removeItem( $node, $data ), - 'bar', '... should return queued item' ); -is( - join( ' ', @{ $node->{_calls}[-1] } ), - "removeData $data", - '... and should call removeData() on it' -); - -# listItems() -{ - $node->{queueTail}{next} = { - item => 'first', - next => { - item => 'second', - next => { item => 'HEAD' } - }, - }; - - my $list = Everything::CacheQueue::listItems($node); - isa_ok( $list, 'ARRAY', 'listItems() should return an array reference' ); - is( scalar @$list, 2, '... of the correct number of items' ); - is( "@$list", 'first second', '... in the correct order (last first)' ); -} - -# queueData() -$node->{numPermanent} = 0; -$node->{queueTail} = 'tail'; -$data = {}; -Everything::CacheQueue::queueData( $node, $data ); -is( - join( ' ', @{ $node->{_calls}[-1] } ), - "insertData $data tail", - 'queueData() should call insertData() with data and cache tail' -); - -$data->{permanent} = 1; -Everything::CacheQueue::queueData( $node, $data ); -is( $node->{numPermanent}, 1, - '... and should increment numPermanent only for permanent data' ); - -# insertData() -{ - my $data = {}; - my $after = { id => 'before next' }; - my $before = { next => $after }; - $node->{queueSize} = 6; - - Everything::CacheQueue::insertData( $node, $data, $before ); - is( $data->{next}{id}, - 'before next', 'insertData() should set data next to before next' ); - is( $data->{prev}, $before, '... and its previous to before' ); - is( $before->{next}, $data, '... and before next to data' ); - is( $after->{prev}, $data, '... and before next prev to data' ); - is( $node->{queueSize}, 7, '... and should increment queueSize' ); -} - -# removeData() -{ - local *removeData = \&Everything::CacheQueue::removeData; - - my $data = { - next => 0, - prev => 0, - }; - - $node->{queueSize} = 0; - is( removeData($node), undef, - 'removeData() should return with nothing in queue' ); - - $node->{queueSize} = 4; - $node->{numPermanent} = 6; - - is( removeData( $node, $data ), - undef, '... or if data has already been removed from queue' ); - - my $next = { prev => 1, }; - - my $prev = { next => 1, }; - - $data = { - next => $next, - prev => $prev, - permanent => 0, - }; - - removeData( $node, $data ); - is( $next->{prev}, $prev, '... should set next prev to previous' ); - is( $prev->{next}, $next, '... should set prev next to next' ); - - is( join( ' ', @$data{qw( next prev )} ), - '0 0', '... and should set next and prev in data to 0' ); - - is( $node->{queueSize}, 3, '... and reduce queueSize' ); - - $data = { - next => $next, - prev => $prev, - permanent => 1, - }; - removeData( $node, $data ); - is( $node->{numPermanent}, 5, - '... but should reduce numPermanent only when removing permanent item' - ); -} - -# createQueueData() -{ - local *cqd = \&Everything::CacheQueue::createQueueData; - - my $queued = cqd( $node, 'foo' ); - isa_ok( $queued, 'HASH', 'createQueueData() should return a hashref' ); - - is( $queued->{item}, 'foo', '... storing data in "item" slot' ); - is( join( ' ', @$queued{qw( next prev )} ), - '0 0', '... setting "next" and "prev" slots both to 0' ); - is( $queued->{permanent}, 0, '... vivifying "permanent" to 0 if needed' ); - - is( cqd( $node, 'foo', 1 )->{permanent}, - 1, '... but should respect passed "permanent" flag' ); -} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-09-22 11:28:17
|
Revision: 910 http://svn.sourceforge.net/everydevel/?rev=910&view=rev Author: paul_the_nomad Date: 2006-09-22 04:28:01 -0700 (Fri, 22 Sep 2006) Log Message: ----------- Move Auth.t tests to unit tests for Auth.pm Modified Paths: -------------- trunk/ebase/t/Everything/Auth.t Added Paths: ----------- trunk/ebase/lib/Everything/Test/Auth.pm Added: trunk/ebase/lib/Everything/Test/Auth.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Auth.pm (rev 0) +++ trunk/ebase/lib/Everything/Test/Auth.pm 2006-09-22 11:28:01 UTC (rev 910) @@ -0,0 +1,136 @@ +package Everything::Test::Auth; + +use base 'Everything::Test'; +use Test::More; +use Test::Exception; +use Test::MockObject; +use File::Spec; +use File::Path; +use SUPER; +use strict; + +sub startup : Test( startup => +5 ) { + my $self = shift; + $self->SUPER; + can_ok( $self->{class}, 'new' ); + + my $db = Test::MockObject->new(); + local *Everything::Auth::DB; + *Everything::Auth::DB = \$db; + $db->set_always( getNode => { node_id => 88 } ); + $self->{db} = $db; + my $instance = $self->{class}->new(); + isa_ok( $instance, $self->{class} ); + $self->{instance} = $instance; + + ok( + exists $INC{'Everything/Auth/EveryAuth.pm'}, + 'new() should load default auth plugin by default' + ); + isa_ok( $instance->{plugin}, 'Everything::Auth::EveryAuth' ); + is( $instance->{options}{guest_user}, + 88, '... setting guest user id from database' ); + + $self->{options} = { guest_user => 77, Auth => 'Plugin' }; + +} + +sub test_load_module : Test(2) { + + my $self = shift; + my $success; + my $options = $self->{options}; + my $package = $self->{class}; + my $path = File::Spec->catdir(qw( lib Everything Auth )); + my $mod; + if ( -d $path or mkpath $path) { + $mod = File::Spec->catfile( $path, 'Plugin.pm' ); + if ( open( OUT, ">$mod" ) ) { + print OUT "package Everything::Auth::Plugin;\n" + . 'sub new { bless {}, $_[0] }' + . "\n1;\n"; + + $success = close OUT; + } + } + + return ( "Cannot open fake auth package", 2 ) unless $success; + $options->{Auth} = 'Plugin'; + my $result = $package->new($options); + isa_ok( $result->{plugin}, 'Everything::Auth::Plugin' ); + is( $result->{options}, $options, '... setting options to passed-in opts' ); + + unlink $mod; + +} + +sub test_load_fake_module : Test(1) { + my $self = shift; + my $options = $self->{options}; + + $options->{Auth} = 'Fake'; + throws_ok { $self->{class}->new($options) } qr/No authentication plugin/, + '... should die if it finds no auth plugin'; + +} + +sub test_exported_subs : Test(18) { + + my $self = shift; + my $package = $self->{class}; + + for my $export (qw( loginUser logoutUser authUser )) { + can_ok( $package, $export ); + my $mock = Test::MockObject->new(); + $mock->set_always( $export => 'user' ) + ->set_always( generateSession => 'generated' ); + + $mock->{plugin} = $mock; + + my $sub = __PACKAGE__->can($export); + + my $result = $sub->( $mock, 'args', 'args' ); + + my ( $method, $args ) = $mock->next_call(); + is( $method, $export, "$export() should delegate to plugin" ); + is_deeply( $args, [ $mock, qw( args args ) ], '... passing all args' ); + + ( $method, $args ) = $mock->next_call(); + is( $method, 'generateSession', '... generating a session' ); + is( $args->[1], 'user', '... for the user' ); + is( $result, 'generated', '... returning the results' ); + } + +} + +sub test_generate_session : Test(5) { + + my $self = shift; + my $package = $self->{class}; + my $db = $self->{db}; + local *Everything::Auth::DB; + *Everything::Auth::DB = \$db; + + can_ok( $package, 'generateSession' ); + my $mock = Test::MockObject->new(); + $mock->{options} = { guest_user => 'guest' }; + $mock->set_always( getVars => 'vars' ); + + $db->set_false('getNode')->clear(); + + throws_ok { Everything::Auth::generateSession($mock) } + qr/Unable to get user!/, 'generateSession() should die with no user'; + my ( $method, $args ) = $db->next_call(); + is( $method, 'getNode', '... so should fetch a user given none' ); + is( $args->[1], 'guest', '... using guest user option' ); + + my @results = Everything::Auth::generateSession( $mock, $mock ); + is_deeply( + \@results, + [ $mock, 'vars' ], + '... returning user and user vars' + ); + +} + +1; Property changes on: trunk/ebase/lib/Everything/Test/Auth.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/t/Everything/Auth.t =================================================================== --- trunk/ebase/t/Everything/Auth.t 2006-09-13 15:27:09 UTC (rev 909) +++ trunk/ebase/t/Everything/Auth.t 2006-09-22 11:28:01 UTC (rev 910) @@ -1,98 +1,31 @@ #!/usr/bin/perl -w -BEGIN -{ - chdir 't' if -d 't'; - unshift @INC, '../lib', '../blib/lib', 'lib'; -} +use Everything::Test::Auth; -use strict; -use File::Path; -use File::Spec; +Everything::Test::Auth->runtests; -use Test::More tests => 32; +__END__ -use Test::Exception; -use Test::MockObject; -my $package = 'Everything::Auth'; +# BEGIN +# { +# chdir 't' if -d 't'; +# unshift @INC, '../lib', '../blib/lib', 'lib'; +# } -use_ok($package) or die; +# use strict; +# use File::Path; +# use File::Spec; -my ( $result, $method, $args, @le ); +# use Test::More tests => 32; -can_ok( $package, 'new' ); -my $db = Test::MockObject->new(); -local *Everything::Auth::DB; -*Everything::Auth::DB = \$db; -$db->set_always( getNode => { node_id => 88 } ); +# use Test::Exception; +# use Test::MockObject; -$result = $package->new(); -isa_ok( $result, $package ); -ok( - exists $INC{'Everything/Auth/EveryAuth.pm'}, - 'new() should load default auth plugin by default' -); -isa_ok( $result->{plugin}, 'Everything::Auth::EveryAuth' ); -is( $result->{options}{guest_user}, - 88, '... setting guest user id from database' ); +my ( $result, $method, $args, @le ); -my $options = { guest_user => 77, Auth => 'Plugin' }; -SKIP: -{ - my $success; - my $path = File::Spec->catdir(qw( lib Everything Auth )); - - if ( -d $path or mkpath $path) - { - my $mod = File::Spec->catfile( $path, 'Plugin.pm' ); - if ( open( OUT, ">$mod" ) ) - { - print OUT "package Everything::Auth::Plugin;\n" - . 'sub new { bless {}, $_[0] }' - . "\n1;\n"; - - $success = close OUT; - } - } - - skip( "Cannot open fake auth package", 2 ) unless $success; - - $result = $package->new($options); - isa_ok( $result->{plugin}, 'Everything::Auth::Plugin' ); - is( $result->{options}, $options, '... setting options to passed-in opts' ); - - rmtree $path; -} - -$options->{Auth} = 'Fake'; -throws_ok { $package->new($options) } qr/No authentication plugin/, - '... should die if it finds no auth plugin'; - -for my $export (qw( loginUser logoutUser authUser )) -{ - can_ok( $package, $export ); - my $mock = Test::MockObject->new(); - $mock->set_always( $export => 'user' ) - ->set_always( generateSession => 'generated' ); - - $mock->{plugin} = $mock; - - my $sub = main->can($export); - $result = $sub->( $mock, 'args', 'args' ); - - ( $method, $args ) = $mock->next_call(); - is( $method, $export, "$export() should delegate to plugin" ); - is_deeply( $args, [ $mock, qw( args args ) ], '... passing all args' ); - - ( $method, $args ) = $mock->next_call(); - is( $method, 'generateSession', '... generating a session' ); - is( $args->[1], 'user', '... for the user' ); - is( $result, 'generated', '... returning the results' ); -} - can_ok( $package, 'generateSession' ); my $mock = Test::MockObject->new(); $mock->{options} = { guest_user => 'guest' }; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-09-22 12:13:37
|
Revision: 911 http://svn.sourceforge.net/everydevel/?rev=911&view=rev Author: paul_the_nomad Date: 2006-09-22 05:13:25 -0700 (Fri, 22 Sep 2006) Log Message: ----------- Move XML.t tests to Unit tests for XML.pm Modified Paths: -------------- trunk/ebase/t/Everything/Auth.t trunk/ebase/t/Everything/XML.t Added Paths: ----------- trunk/ebase/lib/Everything/Test/XML.pm Added: trunk/ebase/lib/Everything/Test/XML.pm =================================================================== --- trunk/ebase/lib/Everything/Test/XML.pm (rev 0) +++ trunk/ebase/lib/Everything/Test/XML.pm 2006-09-22 12:13:25 UTC (rev 911) @@ -0,0 +1,144 @@ +package Everything::Test::XML; + +use strict; +use Test::More; +use Test::MockObject; +use SUPER; + +use base 'Everything::Test'; + +sub startup : Test(startup => +0) { + my $self = shift; + my $mock = Test::MockObject->new; + + $self->{le} = []; + $mock->fake_module( 'Everything', + logErrors => sub { push @{ $self->{le} }, [@_] } ); + $mock->fake_module('XML::DOM'); + + $self->SUPER; + $self->{mock} = $mock; + +} + +sub test_readtag : Test(1) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'readTag' ); + +} + +sub test_initXMLParser : Test(2) { + my $self = shift; + my $package = $self->{class}; + + can_ok( $package, 'initXMLParser' ); + my $unfixed = Everything::XML::_unfixed(); + $unfixed->{foo} = 'bar'; + Everything::XML::initXMLParser(); + is( keys( %{ Everything::XML::_unfixed() } ), + 0, 'initXMLParser() should clear unfixed keys' ); +} + +sub test_fix_nodes : Test(7) { + my $self = shift; + my $package = $self->{class}; + my $mock = $self->{mock}; + + can_ok( $package, 'fixNodes' ); + + my ( @gn, @gnret ); + + no strict 'refs'; + local *{ __PACKAGE__ . '::fixNodes' }; + *{ __PACKAGE__ . '::fixNodes' } = \&{ $self->{class} . '::fixNodes' }; + local *{ __PACKAGE__ . '::_unfixed' }; + *{ __PACKAGE__ . '::_unfixed' } = \&{ $self->{class} . '::_unfixed' }; + use strict 'refs'; + + local *Everything::XML::getNode; + *Everything::XML::getNode = sub { + push @gn, [@_]; + return shift @gnret; + }; + + my $unfixed = _unfixed(); + $unfixed->{foo} = 'bar'; + + fixNodes(0); + is( @{ $self->{le} }, + 0, 'fixNodes() should log nothing unless error flag is set' ); + + fixNodes(1); + is( @{ $self->{le} }, 1, '... but should log with error flag' ); + + @gnret = ($mock) x 4; + + $mock->set_series( applyXMLFix => 1, 0, 1 )->set_true('commitXMLFixes') + ->clear(); + $unfixed->{foo} = [ 1, 2 ]; + + fixNodes('printflag'); + my ( $method, $args ) = $mock->next_call(); + is( $method, 'applyXMLFix', '... calling applyXMLFix() for all unfixed' ); + is( join( '-', @$args ), + "$mock-1-printflag", '... with fix and print error' ); + is_deeply( $unfixed, { foo => [1] }, '... saving only unfixed nodes' ); + + $mock->clear(); + + $unfixed = { bar => [] }; + fixNodes('printflag'); + is( $mock->next_call(2), 'commitXMLFixes', '... committing fixes' ); + +} + +sub test_xml2node : Test(1) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'xml2node' ); +} + +sub test_xmlfile2node : Test(1) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'xmlfile2node' ); +} + +sub test_gen_basic_tag : Test(1) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'genBasicTag' ); +} + +sub test_parse_basic_tag : Test(1) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'parseBasicTag' ); +} + +sub test_path_xml_where : Test(1) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'patchXMLwhere' ); +} + +sub test_make_xml_safe : Test(1) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'makeXmlSafe' ); +} + +sub test_unmake_xml_safe : Test(1) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'unMakeXmlSafe' ); +} + +sub test_get_field_type : Test(1) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'getFieldType' ); +} + +1; Property changes on: trunk/ebase/lib/Everything/Test/XML.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/t/Everything/Auth.t =================================================================== --- trunk/ebase/t/Everything/Auth.t 2006-09-22 11:28:01 UTC (rev 910) +++ trunk/ebase/t/Everything/Auth.t 2006-09-22 12:13:25 UTC (rev 911) @@ -4,40 +4,3 @@ Everything::Test::Auth->runtests; -__END__ - - -# BEGIN -# { -# chdir 't' if -d 't'; -# unshift @INC, '../lib', '../blib/lib', 'lib'; -# } - -# use strict; -# use File::Path; -# use File::Spec; - -# use Test::More tests => 32; - -# use Test::Exception; -# use Test::MockObject; - -my ( $result, $method, $args, @le ); - - - -can_ok( $package, 'generateSession' ); -my $mock = Test::MockObject->new(); -$mock->{options} = { guest_user => 'guest' }; -$mock->set_always( getVars => 'vars' ); - -$db->set_false('getNode')->clear(); - -throws_ok { Everything::Auth::generateSession($mock) } qr/Unable to get user!/, - 'generateSession() should die with no user'; -( $method, $args ) = $db->next_call(); -is( $method, 'getNode', '... so should fetch a user given none' ); -is( $args->[1], 'guest', '... using guest user option' ); - -my @results = Everything::Auth::generateSession( $mock, $mock ); -is_deeply( \@results, [ $mock, 'vars' ], '... returning user and user vars' ); Modified: trunk/ebase/t/Everything/XML.t =================================================================== --- trunk/ebase/t/Everything/XML.t 2006-09-22 11:28:01 UTC (rev 910) +++ trunk/ebase/t/Everything/XML.t 2006-09-22 12:13:25 UTC (rev 911) @@ -1,92 +1,6 @@ #!/usr/bin/perl -w -use strict; +use Everything::Test::XML; -BEGIN -{ - chdir 't' if -d 't'; - unshift @INC, '../blib/lib', 'lib/', '..'; -} +Everything::Test::XML->runtests; -use strict; -use vars qw( $AUTOLOAD ); - -use Test::More tests => 19; -use Test::MockObject; - -my $mock = Test::MockObject->new(); - -my ( $method, $args, $results, @le ); - -$mock->fake_module( 'Everything', logErrors => sub { push @le, [@_] } ); -$mock->fake_module('XML::DOM'); - -my $package = 'Everything::XML'; -use_ok($package) or exit; - -sub AUTOLOAD -{ - $AUTOLOAD =~ s/main:://; - if ( my $sub = $package->can($AUTOLOAD) ) - { - no strict 'refs'; - *{$AUTOLOAD} = $sub; - goto &$AUTOLOAD; - } -} - -can_ok( $package, 'readTag' ); - -can_ok( $package, 'initXMLParser' ); -my $unfixed = _unfixed(); -$unfixed->{foo} = 'bar'; -initXMLParser(); -is( keys( %{ _unfixed() } ), 0, 'initXMLParser() should clear unfixed keys' ); - -can_ok( $package, 'fixNodes' ); -{ - my ( @gn, @gnret ); - - local *Everything::XML::getNode; - *Everything::XML::getNode = sub { - push @gn, [@_]; - return shift @gnret; - }; - - my $unfixed = _unfixed(); - $unfixed->{foo} = 'bar'; - - fixNodes(0); - is( @le, 0, 'fixNodes() should log nothing unless error flag is set' ); - - fixNodes(1); - is( @le, 1, '... but should log with error flag' ); - - @gnret = ($mock) x 4; - - $mock->set_series( applyXMLFix => 1, 0, 1 )->set_true('commitXMLFixes') - ->clear(); - $unfixed->{foo} = [ 1, 2 ]; - - fixNodes('printflag'); - ( $method, $args ) = $mock->next_call(); - is( $method, 'applyXMLFix', '... calling applyXMLFix() for all unfixed' ); - is( join( '-', @$args ), - "$mock-1-printflag", '... with fix and print error' ); - is_deeply( $unfixed, { foo => [1] }, '... saving only unfixed nodes' ); - - $mock->clear(); - - $unfixed = { bar => [] }; - fixNodes('printflag'); - is( $mock->next_call(2), 'commitXMLFixes', '... committing fixes' ); -} - -can_ok( $package, 'xml2node' ); -can_ok( $package, 'xmlfile2node' ); -can_ok( $package, 'genBasicTag' ); -can_ok( $package, 'parseBasicTag' ); -can_ok( $package, 'patchXMLwhere' ); -can_ok( $package, 'makeXmlSafe' ); -can_ok( $package, 'unMakeXmlSafe' ); -can_ok( $package, 'getFieldType' ); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-09-25 13:10:35
|
Revision: 912 http://svn.sourceforge.net/everydevel/?rev=912&view=rev Author: paul_the_nomad Date: 2006-09-25 06:10:14 -0700 (Mon, 25 Sep 2006) Log Message: ----------- Turning Mail.t tests to unit tests. Also small amendment in Mail.pm Modified Paths: -------------- trunk/ebase/lib/Everything/Mail.pm trunk/ebase/t/Everything/Mail.t Added Paths: ----------- trunk/ebase/lib/Everything/Test/Mail.pm Modified: trunk/ebase/lib/Everything/Mail.pm =================================================================== --- trunk/ebase/lib/Everything/Mail.pm 2006-09-22 12:13:25 UTC (rev 911) +++ trunk/ebase/lib/Everything/Mail.pm 2006-09-25 13:10:14 UTC (rev 912) @@ -7,7 +7,7 @@ use strict; use Everything; - +use IO::File; use Mail::Sender; use Mail::Address; use Scalar::Util 'reftype'; @@ -94,14 +94,15 @@ my ( $from, $to, $subject, $body ); foreach my $file (@$files) { - unless ( open FILE, "<$file" ) + my $fh; + unless ( $fh = IO::File->new("< $file") ) { Everything::logErrors("mail2node could not open '$file': $!"); next; } $from = $to = $subject = $body = ''; - while (<FILE>) + while (<$fh>) { my $line = $_ || ""; unless ($subject) @@ -126,13 +127,12 @@ else { - # Need to add the newline to preserve it correctly - $body .= $line . "\n"; + $body .= $line; } } - close(FILE); + $fh->close; unless ($subject) { Added: trunk/ebase/lib/Everything/Test/Mail.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Mail.pm (rev 0) +++ trunk/ebase/lib/Everything/Test/Mail.pm 2006-09-25 13:10:14 UTC (rev 912) @@ -0,0 +1,568 @@ +package Everything::Test::Mail; + +use base 'Everything::Test'; +use Test::More; +use Test::MockObject; +use File::Spec; +use File::Temp; +use IO::File; +use SUPER; +use strict; +use warnings; + +sub startup : Test(startup => +0) { + my $self = shift; + + # We'll need a few MockObjects here + + my $mock = Test::MockObject->new(); + my $MS = Test::MockObject->new(); + my $SETTINGS = Test::MockObject->new(); + + # A few different variables to hold parameters being passed in and out + + # For now, we are going to start off so that a call + # to getNode("mail settings", "setting") will fail + + $mock->set_always( "SETTINGS", undef ); + + # Begin the faking process with Everything.pm + + $self->{warnings} = []; + $self->{errors} = []; + $self->{recipients} = []; + + $mock->fake_module( + "Everything", + + logErrors => + + sub { + my ( $le_wrn, $le_err ) = @_; + push @{ $self->{warnings} }, $le_wrn if $le_wrn; + push @{ $self->{errors} }, $le_err if $le_err; + }, + + ); + + my $fh = Test::MockObject->new(); + + # Because we can't actually call $MS->new directly for our + # aggrigated "mock" method, register another handler for + # the new method for Mail::Sender + + $mock->fake_module( + 'Mail::Sender', + + new => sub { $MS->newMethod(@_); }, + + ); + + # This strips off the extra creation parameters and returns + # the blessed object. + + $MS->mock( "newMethod", sub { return $MS } ); + + # Because most of the inner workings of our MailMsg will + # remain mostly the same, we'll create a mocked object to + # pick through a series of results. + + $MS->mock( "MailMsg_return", sub { $MS } ); + $MS->mock( + "MailMsg", + sub { + + my ( $this, $par_in ) = @_; + push @{ $self->{recipients} }, $par_in->{to}; + $MS->MailMsg_return(); + } + ); + + # We want to test whether or not someone closes this object + # like they should. This just trips a flag for it. + + $MS->mock( "Close", sub { 1 } ); + + # Also, $SETTINGS is going to start by failing all calls to + # getVars. This will get overidden lower in the code + + $SETTINGS->set_always( "getVars", undef ); + + $self->{MS} = $MS; + $self->{mock} = $mock; + $self->{SETTINGS} = $SETTINGS; + $self->SUPER; + +} + +sub test_node2mail : Test(29) { + my $self = shift; + my $MS = $self->{MS}; + my $SETTINGS = $self->{SETTINGS}; + my $mock = $self->{mock}; + + $mock->fake_module( + "Everything", + + getNode => + + sub { + my ( $nparam, $tparam ) = @_; + + return unless $nparam; + + if ( $nparam eq "mail settings" and $tparam eq "setting" ) { + + return $mock->SETTINGS; + } + + if ( ( ref $nparam ) eq "HASH" ) { + + } + + my $results = { + 1 => undef, + 2 => { title => "", doctext => "test body" }, + 3 => { title => " ", doctext => "test body" }, + 4 => { title => "test title", doctext => "" }, + 5 => { title => "test title", doctext => " " }, + 6 => { title => "test title", doctext => "test body" }, + 7 => { title => "test title", from_address => 'me' }, + }; + + return $results->{$nparam}; + }, + + logErrors => + + sub { + my ( $le_wrn, $le_err ) = @_; + push @{ $self->{warnings} }, $le_wrn if $le_wrn; + push @{ $self->{errors} }, $le_err if $le_err; + }, + + ); + + no strict 'refs'; + local *{ __PACKAGE__ . '::node2mail' }; + *{ __PACKAGE__ . '::node2mail' } = \&{ $self->{class} . '::node2mail' }; + use strict 'refs'; + + ## Unfortunately, Everything.pm exports getNode to + ## everything::mail. This has to be fixed. At the moment, we can + ## fake it like this. + local *Everything::Mail::getNode; + *Everything::Mail::getNode = sub { Everything::getNode(@_) }; + + ## Ditto + local *Everything::Mail::getType; + *Everything::Mail::getType = sub { return uc( $_[0] ); }; + + # This is just test fodder, and nothing in particular + my $email = "root\@nowhereinparticular.com"; + + # Various combinatorics of missing arguments. + + ok( !node2mail(), 'node2mail() should return given no arguments' ); + ok( !node2mail($email), '... or if $node is null' ); + ok( !node2mail( $email, 1 ), '... or if getNode returns undef' ); + + # Warnings that would most likely be helpful for debugging + + $self->{warnings} = []; + node2mail( $email, 2 ); + like( + join( "", @{ $self->{warnings} } ), + qr/empty subject/, +'node2mail should log a warning if sending an email with an empty subject' + ); + + $self->{warnings} = []; + node2mail( $email, 3 ); + like( + join( "", @{ $self->{warnings} } ), + qr/empty subject/, +'node2mail should log a warning if sending an email with a subject with all spaces' + ); + + $self->{warnings} = []; + node2mail( $email, 4 ); + like( + join( "", @{ $self->{warnings} } ), + qr/empty body/, + 'node2mail should log a warning if sending an email with an empty body' + ); + + $self->{warnings} = []; + node2mail( $email, 5 ); + like( + join( "", @{ $self->{warnings} } ), + qr/empty body/, +'node2mail should log a warning if sending an email with a body with all spaces' + ); + + # If you forget to clear the variables, you get false positives! + + $MS->clear; + node2mail( $email, 6 ); + + like( + join( "", @{ $self->{warnings} } ), + qr/Can\'t find the mail settings/, + 'node2mail should log a warning if it can\'t find the mail settings' + ); + + my ( $method, $args ) = $MS->next_call; + ok( $args->[2]->{smtp} eq "localhost", + 'node2mail should default to send via localhost if none is specified' ); + ok( + $args->[2]->{from} eq "root\@localhost", +'node2mail should default to send from root@localhost if none is specified' + ); + + ### Test parameters passed to Mail::Sender's 'new' method + $MS->clear; + node2mail( $email, 7 ); + ( $method, $args ) = $MS->next_call; + is( $args->[2]->{from}, 'me', '... or the from_address in the mail node' ); + + # From here on out getVars will return valid psuedo-hashes. + + $SETTINGS->remove("getVars"); + $SETTINGS->set_series( + "getVars", + undef, + { mailserver => "mymailserver" }, + { systemMailFrom => $email }, + ( { mailserver => "mymailserver", systemMailFrom => $email } ) x 5, + ); + $mock->remove("SETTINGS"); + $mock->set_always( "SETTINGS", $SETTINGS ); + + # Test if getVars fails + + $MS->clear; + + node2mail( $email, 6 ); + + ( $method, $args ) = $MS->next_call; + ok( $args->[2]->{smtp} eq "localhost", + 'node2mail should default to send via localhost if getVars fails' ); + ok( + $args->[2]->{from} eq "root\@localhost", + 'node2mail should default to send from root@localhost if getVars fails' + ); + + $MS->clear; + node2mail( $email, 6 ); + ( $method, $args ) = $MS->next_call; + ok( + $args->[2]->{smtp} eq "mymailserver", +'node2mail should use $SETTINGS->{mailserver} if in partial mail settings' + ); + ok( + $args->[2]->{from} eq "root\@localhost", +'node2mail should default to send from root@localhost if not in partial mail settings' + ); + + # Tests if "mail settings" have trouble with not having one or more + # settings + + $MS->clear; + node2mail( $email, 6 ); + ( $method, $args ) = $MS->next_call; + ok( + $args->[2]->{smtp} eq "localhost", +'node2mail should default to send via localhost if not in partial mail settings' + ); + ok( + $args->[2]->{from} eq $email, +'node2mail should use $SETTINGS->{systemMailFrom} if in partial mail settings' + ); + + $self->{recipients} = []; + + # The normal case: $SETTINGS is populated correctly + + $MS->clear; + node2mail( $email, 6 ); + ( $method, $args ) = $MS->next_call; + ok( + $args->[2]->{smtp} eq "mymailserver", + 'node2mail should send via $SETTINGS->{mailserver} if in mail settings' + ); + ok( + $args->[2]->{from} eq $email, + 'node2mail should use $SETTINGS->{systemMailFrom} if in mail settings' + ); + + # Check MailMsg + + ( $method, $args ) = $MS->next_call; + is( $method, 'MailMsg', 'node2mail should call MailMsg next' ); + + is( $args->[1]->{msg}, + "test body", 'node2mail calls MailMsg with the correct $body' ); + is( $args->[1]->{subject}, + "test title", 'node2mail calls MailMsg with the correct $subject' ); + is( $args->[1]->{to}, + $email, 'node2mail calls MailMsg with the correct $addr' ); + + ( $method, $args ) = $MS->next_call; + ( $method, $args ) = $MS->next_call; + is( $method, 'Close', 'node2mail closes Mail::Sender when done' ); + + $self->{recipients} = []; + + # Make sure that we can pass in an arrayref of addresses + + my $arraymembers = + [ "john\@foo.com", "perl\@lovesyou.org", "dave\@matthews.za" ]; + + node2mail( $arraymembers, 6 ); + ok( + ( join "", @$arraymembers ) eq ( join "", @{ $self->{recipients} } ), +'node2mail should accept and process an arrayref of addresses without missing one' + ); + + # MailMsg fails 100% from here + + $self->{warnings} = []; + $self->{recipients} = []; + $self->{errors} = []; + $MS->remove("MailMsg_return"); + $MS->mock( "MailMsg_return", sub { -250 } ); + + ok( node2mail( $email, 6 ), + 'node2mail should still succeed if mail sending is unsuccessful' ); + like( + join( "", @{ $self->{warnings} } ), + qr/MailMsg failed/, + 'node2mail should log a warning if MailMsg failed' + ); + + # Mail::Sender->new() fails from here 100% + + $MS->remove("newMethod"); + $MS->mock( "newMethod", sub { undef } ); + + ok( !node2mail( $email, 6 ), + 'node2mail should return undef if Mail::Sender object creation fails' ); + like( + join( "", @{ $self->{errors} } ), + qr/Mail\:\:Sender creation failed/, + 'node2mail should log the Mail::Sender error message if it fails' + ); + +} + +sub test_mail2node : Test(20) { + + my $self = shift; + my $mock = $self->{mock}; + my $package = $self->{class}; + +########################## + # Test plan: +########################## +# mail2node +# take file +# get array of files (can be ref) +# use Mail::Address +# loop through files +# open file +# look for 'Subject:' line +# get 'From:' and make Mail::Address parse it, store in $from +# get 'To:' line, parse it, store in $to +# get 'Subject:' line, store in $subject +# slurp rest of file into $body (potential bug) +# getNode of 'user' type, given registered user email address +# getNode for new blank 'mail' node +# set author, from_address, and body +# insert node + + local *Everything::Mail::getId; + *Everything::Mail::getId = sub { Everything::getId(@_) }; + + can_ok( $package, 'mail2node' ) || return 'Can\'t mail2node'; + + no strict 'refs'; + local *{ __PACKAGE__ . '::mail2node' }; + *{ __PACKAGE__ . '::mail2node' } = \&{ $self->{class} . '::mail2node' }; + use strict 'refs'; + + local *Everything::Mail::getType; + *Everything::Mail::getType = sub { return uc( $_[0] ); }; + + use_ok("Mail::Address"); + + ok( !mail2node(), 'mail2node() should fail without files' ); + ok( ( join "", @{ $self->{warnings} } ) =~ /No input files for mail2node/, + '...and should throw a warning saying so' ); + + $self->{warnings} = []; + + ok( mail2node('/dummy/file'), + 'mail2node should return gracefully if it can\'t open up a file' ); + ok( ( join "", @{ $self->{warnings} } ) =~ /mail2node could not open/, + '...throwing a warning saying so' ); + + #Set up tests for invalid reading + + my $tmpdir = File::Spec->tmpdir; + my $fh = File::Temp->new( + TEMPLATE => $$ . 'XXXXXXX', + DIR => $tmpdir, + UNLINK => 0 + ); + my $fname = $fh->filename; + $self->{warnings} = []; + + $fh->close; + ok( mail2node($fname), +'mail2node should return gracefully if it doesn\'t have enough to make a mail node' + ); + ok( + ( join "", @{ $self->{warnings} } ) =~ + /doesn\'t appear to be a valid mail file/, + '...and should throw a warning saying so' + ); + + $self->{warnings} = []; + $self->{errors} = []; + + my $m2n_node = Test::MockObject->new( {} ); + my $m2n_user = Test::MockObject->new( {} ); + my $got_root = 0; + + $mock->fake_module( + "Everything", + getNode => sub { + + my ( $param, $nparam ) = @_; + + #if we're getting the user + return $m2n_user->getMe() if ( ref($param) eq "HASH" ); + + #if we're getting the node itself + return $m2n_node->getMe() if ( $nparam eq "mail" ); + + #if we're getting the root user + if ( $param eq "root" and $nparam eq "user" ) { + $got_root = 1; + return { node_id => 5 }; + } + }, + + getId => sub { + + my ($node) = @_; + return $node->{node_id}; + }, + ); + + no strict 'refs'; + local *{ $self->{class} . '::getNode' }; + *{ $self->{class} . '::getNode' } = *{Everything::getNode}{CODE}; + use strict 'refs'; + + $m2n_user->set_always( "getMe", undef ); + $m2n_node->set_always( "getMe", undef ); + + $m2n_node->set_always( "insert", 1 ); + + $self->{errors} = []; + $self->{warnings} = []; + + #No "To:" parameter + $fh = IO::File->new( $fname, 'w' ) || return "Can't complete tests, $!"; + print $fh + "From: testing\@test.com\nSubject: this is a test email!\n\nTesting!\n"; + $fh->close; + + mail2node($fname); + ok( + join( "", @{ $self->{warnings} } ) =~ +/mail2node\: No \'To\:\' parameter specified\. Defaulting to user \'root\'/, + 'mail2node should default to root and warn if it doesn\'t find a To: ' + ); + ok( $got_root, '...and actually gets the root user' ); + + $self->{errors} = []; + $self->{warnings} = []; + + $fh = IO::File->new( $fname, 'w' ) || return "Can't complete tests, $!"; + print $fh + "From: testing\@test.com\nSubject: this is a test email!\n\nTesting!\n"; + $fh->close; + + mail2node($fname); + ok( + join( "", @{ $self->{errors} } ) =~ + /mail2node\: Node creation of type mail failed\!/, + "Throw an error if mail2node creation directive fails" + ); + + $m2n_node->set_always( "getMe", $m2n_node ); + + $m2n_node->{type_nodetype} = 5; #fake mail nodetype + + $self->{errors} = []; + $self->{warnings} = []; + + $m2n_node->clear(); + $fh = IO::File->new( $fname, 'w' ) || return "Can't complete tests, $!"; + print $fh +"To: foo\@bar.com\nFrom: testing\@test.com\nSubject: this is a test email!\n\nTesting!\nHello\n"; + + $fh->close; + + mail2node($fname); + $m2n_node->called_ok( "insert", "mail2node calls insert" ); + is( $m2n_node->call_pos(2), + "insert", "insert gets called in the right spot" ); + is( $m2n_node->call_args_pos( 2, 2 ), + "-1", "insert gets called without permissions (-1)" ); + is( + $m2n_node->{title}, + "this is a test email!", + "...and the subject gets set correctly" + ); + is( $m2n_node->{from_address}, + "testing\@test.com", "...and the from_address gets set correctly" ); + is( $m2n_node->{doctext}, "\nTesting!\nHello\n", + "...and the doctext gets set correctly" ); + is( $m2n_node->{author_user}, + "5", "...and gets the (faked) root_id correctly!" ); + + $m2n_user->set_always( "getMe", $m2n_user ); + + $m2n_user->{node_id} = 24; + $m2n_user->{title} = "not root"; + + $self->{errors} = []; + $self->{warnings} = []; + + $m2n_node->clear(); + + $fh = IO::File->new( $fname, 'w' ) || return "Can't complete tests, $!"; + print $fh +"To: foo\@bar.com\nFrom: testing\@test.com\nSubject: this is a test email!\n\nTesting!\nHello\n"; + $fh->close; + + mail2node($fname); + $m2n_node->called_ok( "insert", + "mail2node calls insert when it can get the user" ); + is( $m2n_node->{author_user}, "24", "...and has the correct (faked) id" ); + +############################### + # Tests left: +############################### + # See what happens if Mail::Address returns null + # Badly formed email addresses + # Have hard limit of size of email (size of doctext) + # Make sure multiple files works + unlink $fname; +} + +1; Property changes on: trunk/ebase/lib/Everything/Test/Mail.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/t/Everything/Mail.t =================================================================== --- trunk/ebase/t/Everything/Mail.t 2006-09-22 12:13:25 UTC (rev 911) +++ trunk/ebase/t/Everything/Mail.t 2006-09-25 13:10:14 UTC (rev 912) @@ -1,523 +1,6 @@ #!/usr/bin/perl -w -use Test::More tests => 53; -use Test::MockObject; +use Everything::Test::Mail; -my $package = "Everything::Mail"; +Everything::Test::Mail->runtests; -################################################################ -# -# t/email.t -# -# Test Everything::Mail -# -# - -#Load in the blib paths -BEGIN -{ - chdir 't' if -d 't'; - use lib '../blib/lib', 'lib', '..'; -} - -# We'll need a few MockObjects here - -my $mock = Test::MockObject->new(); -my $MS = Test::MockObject->new(); -my $SETTINGS = Test::MockObject->new(); - -# A few different variables to hold parameters being passed in and out - -my ( - $le_wrn, $le_err, $ms_isclosed, $ms_params, $ms_gotsettings, - $ms_addr, $ms_subject, $ms_body, $ms_from -); - -my ( @WARNINGS, @ERRORS, @RECIPIENTS ); - -# For now, we are going to start off so that a call -# to getNode("mail settings", "setting") will fail - -$mock->set_always( "SETTINGS", undef ); - -# Begin the faking process with Everything.pm - -$mock->fake_module( - "Everything", - - getNode => - - sub { - my ( $nparam, $tparam ) = @_; - - return unless $nparam; - - if ( $nparam eq "mail settings" and $tparam eq "setting" ) - { - $ms_gotsettings = 1; - return $mock->SETTINGS; - } - - if ( ( ref $nparam ) eq "HASH" ) - { - - } - - my $results = { - 1 => undef, - 2 => { title => "", doctext => "test body" }, - 3 => { title => " ", doctext => "test body" }, - 4 => { title => "test title", doctext => "" }, - 5 => { title => "test title", doctext => " " }, - 6 => { title => "test title", doctext => "test body" }, - 7 => { title => "test title", from_address => 'me' }, - }; - - return $results->{$nparam}; - }, - - logErrors => - - sub { - ( $le_wrn, $le_err ) = @_; - push @WARNINGS, $le_wrn if $le_wrn; - push @ERRORS, $le_err if $le_err; - }, - -); - -my $fh = Test::MockObject->new(); - -# Because we can't actually call $MS->new directly for our -# aggrigated "mock" method, register another handler for -# the new method for Mail::Sender - -$mock->fake_module( - 'Mail::Sender', - - new => sub { $MS->newMethod(@_); }, - -); - -# This strips off the extra creation parameters and returns -# the blessed object. - -$MS->mock( "newMethod", sub { $ms_params = $_[2]; return $MS } ); - -# Because most of the inner workings of our MailMsg will -# remain mostly the same, we'll create a mocked object to -# pick through a series of results. - -$MS->mock( "MailMsg_return", sub { $MS } ); -$MS->mock( - "MailMsg", - sub { - - my ( $this, $par_in ) = @_; - $ms_addr = $par_in->{to}; - $ms_body = $par_in->{msg}; - $ms_subject = $par_in->{subject}; - $ms_from = $par_in->{from}; - push @RECIPIENTS, $ms_addr; - $MS->MailMsg_return(); - } -); - -# We want to test whether or not someone closes this object -# like they should. This just trips a flag for it. - -$MS->mock( "Close", sub { $ms_isclosed = 1 } ); - -# Also, $SETTINGS is going to start by failing all calls to -# getVars. This will get overidden lower in the code - -$SETTINGS->set_always( "getVars", undef ); - -# Everything::getNode needs to be jumpstarted into the space -# for Everything::Mail. My thanks goes to chromatic for this -# smart little hack. - -local *Everything::Mail::getNode; -*Everything::Mail::getNode = sub { Everything::getNode(@_) }; - -local *Everything::Mail::getType; -*Everything::Mail::getType = sub { return uc( $_[0] ); }; - -local *Everything::Mail::FILE; -tie *Everything::Mail::FILE, 'MockHandle', "This will never be read", 1; -use MockHandle; - -my $MockHandle_closed; - -local *MockHandle::CLOSE; -*MockHandle::CLOSE = sub { $MockHandle_closed = 1 }; - -# Does use Everything::Mail still return 1? This will tell us: - -use_ok($package) or exit; -{ - - # This is just test fodder, and nothing in particular - my $email = "root\@nowhereinparticular.com"; - - # Various combinatorics of missing arguments. - - ok( !node2mail(), 'node2mail() should return given no arguments' ); - ok( !node2mail($email), '... or if $node is null' ); - ok( !node2mail( $email, 1 ), '... or if getNode returns undef' ); - - # Warnings that would most likely be helpful for debugging - - @WARNINGS = (); - node2mail( $email, 2 ); - like( - join( "", @WARNINGS ), - qr/empty subject/, -'node2mail should log a warning if sending an email with an empty subject' - ); - - @WARNINGS = (); - node2mail( $email, 3 ); - like( - join( "", @WARNINGS ), - qr/empty subject/, -'node2mail should log a warning if sending an email with a subject with all spaces' - ); - - @WARNINGS = (); - node2mail( $email, 4 ); - like( - join( "", @WARNINGS ), - qr/empty body/, - 'node2mail should log a warning if sending an email with an empty body' - ); - - @WARNINGS = (); - node2mail( $email, 5 ); - like( - join( "", @WARNINGS ), - qr/empty body/, -'node2mail should log a warning if sending an email with a body with all spaces' - ); - - # If you forget to clear the variables, you get false positives! - - $ms_params->{smtp} = ""; - $ms_params->{from} = ""; - $ms_gotsettings = 0; - $le_wrn = ""; - - node2mail( $email, 6 ); - ok( $ms_gotsettings, -'node2mail should request getNode(\'mail settings\', \'setting\') on valid body and subject (no valid getVars)' - ); - like( - join( "", @WARNINGS ), - qr/Can\'t find the mail settings/, - 'node2mail should log a warning if it can\'t find the mail settings' - ); - - ok( $ms_params->{smtp} eq "localhost", - 'node2mail should default to send via localhost if none is specified' ); - ok( - $ms_params->{from} eq "root\@localhost", -'node2mail should default to send from root@localhost if none is specified' - ); - - node2mail( $email, 7 ); - is( $ms_params->{from}, 'me', '... or the from_address in the mail node' ); - - $ms_gotsettings = 0; - $ms_params->{smtp} = ""; - $ms_params->{from} = ""; - - # From here on out getVars will return valid psuedo-hashes. - - $SETTINGS->remove("getVars"); - $SETTINGS->set_series( - "getVars", - undef, - { mailserver => "mymailserver" }, - { systemMailFrom => $email }, - ( { mailserver => "mymailserver", systemMailFrom => $email } ) x 5, - ); - $mock->remove("SETTINGS"); - $mock->set_always( "SETTINGS", $SETTINGS ); - - # Test if getVars fails - - node2mail( $email, 6 ); - ok( $ms_gotsettings, -'node2mail should request getNode(\'mail settings\', \'setting\') on valid body and subject (valid getVars)' - ); - ok( $ms_params->{smtp} eq "localhost", - 'node2mail should default to send via localhost if getVars fails' ); - ok( - $ms_params->{from} eq "root\@localhost", - 'node2mail should default to send from root@localhost if getVars fails' - ); - - node2mail( $email, 6 ); - ok( - $ms_params->{smtp} eq "mymailserver", -'node2mail should use $SETTINGS->{mailserver} if in partial mail settings' - ); - ok( - $ms_params->{from} eq "root\@localhost", -'node2mail should default to send from root@localhost if not in partial mail settings' - ); - - # Tests if "mail settings" have trouble with not having one or more - # settings - - node2mail( $email, 6 ); - ok( - $ms_params->{smtp} eq "localhost", -'node2mail should default to send via localhost if not in partial mail settings' - ); - ok( - $ms_params->{from} eq $email, -'node2mail should use $SETTINGS->{systemMailFrom} if in partial mail settings' - ); - - $ms_body = $ms_subject = $ms_addr = ""; - $ms_isclosed = 0; - @RECIPIENTS = (); - - # The normal case: $SETTINGS is populated correctly - - node2mail( $email, 6 ); - ok( - $ms_params->{smtp} eq "mymailserver", - 'node2mail should send via $SETTINGS->{mailserver} if in mail settings' - ); - ok( - $ms_params->{from} eq $email, - 'node2mail should use $SETTINGS->{systemMailFrom} if in mail settings' - ); - - # Check MailMsg - - ok( $ms_body eq "test body", - 'node2mail calls MailMsg with the correct $body' ); - ok( $ms_subject eq "test title", - 'node2mail calls MailMsg with the correct $subject' ); - ok( $ms_addr eq $email, 'node2mail calls MailMsg with the correct $addr' ); - is( - $ms_params->{from}, - 'ro...@no...', - '... and the correct from address' - ); - ok( $ms_isclosed, 'node2mail closes Mail::Sender when done' ); - - @RECIPIENTS = (); - - # Make sure that we can pass in an arrayref of addresses - - my $arraymembers = - [ "john\@foo.com", "perl\@lovesyou.org", "dave\@matthews.za" ]; - - node2mail( $arraymembers, 6 ); - ok( - ( join "", @$arraymembers ) eq ( join "", @RECIPIENTS ), -'node2mail should accept and process an arrayref of addresses without missing one' - ); - - # MailMsg fails 100% from here - - @RECIPIENTS = (); - @WARNINGS = (); - @ERRORS = (); - $MS->remove("MailMsg_return"); - $MS->mock( "MailMsg_return", sub { -250 } ); - - ok( node2mail( $email, 6 ), - 'node2mail should still succeed if mail sending is unsuccessful' ); - like( - join( "", @WARNINGS ), - qr/MailMsg failed/, - 'node2mail should log a warning if MailMsg failed' - ); - - # Mail::Sender->new() fails from here 100% - - $MS->remove("newMethod"); - $MS->mock( "newMethod", sub { undef } ); - - ok( !node2mail( $email, 6 ), - 'node2mail should return undef if Mail::Sender object creation fails' ); - like( - join( "", @ERRORS ), - qr/Mail\:\:Sender creation failed/, - 'node2mail should log the Mail::Sender error message if it fails' - ); - -} - -########################## -# Test plan: -########################## -# mail2node -# take file -# get array of files (can be ref) -# use Mail::Address -# loop through files -# open file -# look for 'Subject:' line -# get 'From:' and make Mail::Address parse it, store in $from -# get 'To:' line, parse it, store in $to -# get 'Subject:' line, store in $subject -# slurp rest of file into $body (potential bug) -# getNode of 'user' type, given registered user email address -# getNode for new blank 'mail' node -# set author, from_address, and body -# insert node - -local *Everything::Mail::getId; -*Everything::Mail::getId = sub { Everything::getId(@_) }; - -can_ok( $package, 'mail2node' ); - -use_ok("Mail::Address"); - -ok( !mail2node(), 'mail2node() should fail without files' ); -ok( ( join "", @WARNINGS ) =~ /No input files for mail2node/, - '...and should throw a warning saying so' ); - -@WARNINGS = (); - -ok( mail2node('/dummy/file'), - 'mail2node should return gracefully if it can\'t open up a file' ); -ok( ( join "", @WARNINGS ) =~ /mail2node could not open/, - '...throwing a warning saying so' ); - -#Set up tests for invalid reading -untie *Everything::Mail::FILE; -tie *Everything::Mail::FILE, 'MockHandle', "THIS IS INVALID TEXT"; - -@WARNINGS = (); -$MockHandle_closed = 0; -ok( mail2node('/dummy/file'), -'mail2node should return gracefully if it doesn\'t have enough to make a mail node' -); -ok( ( join "", @WARNINGS ) =~ /doesn\'t appear to be a valid mail file/, - '...and should throw a warning saying so' ); -ok( $MockHandle_closed, '...and should close the file handle' ); - -#No "To:" parameter -untie *Everything::Mail::FILE; -tie *Everything::Mail::FILE, 'MockHandle', - "From: testing\@test.com\nSubject: this is a test email!\n\nTesting!\n"; - -@WARNINGS = (); -@ERRORS = (); -$MockHandle_closed = 0; - -my $m2n_node = Test::MockObject->new( {} ); -my $m2n_user = Test::MockObject->new( {} ); -my $got_root = 0; - -$mock->fake_module( - "Everything", - getNode => sub { - - my ( $param, $nparam ) = @_; - - #if we're getting the user - return $m2n_user->getMe() if ( ref($param) eq "HASH" ); - - #if we're getting the node itself - return $m2n_node->getMe() if ( $nparam eq "mail" ); - - #if we're getting the root user - if ( $param eq "root" and $nparam eq "user" ) - { - $got_root = 1; - return { node_id => 5 }; - } - }, - - getId => sub { - - my ($node) = @_; - return $node->{node_id}; - }, -); - -$m2n_user->set_always( "getMe", undef ); -$m2n_node->set_always( "getMe", undef ); - -$m2n_node->set_always( "insert", 1 ); - -@ERRORS = (); -@WARNINGS = (); -mail2node('/dummy/file'); -ok( - join( "", @WARNINGS ) =~ -/mail2node\: No \'To\:\' parameter specified\. Defaulting to user \'root\'/, - 'mail2node should default to root and warn if it doesn\'t find a To: ' -); -ok( $got_root, '...and actually gets the root user' ); - -untie *Everything::Mail::FILE; -tie *Everything::Mail::FILE, 'MockHandle', - "From: testing\@test.com\nSubject: this is a test email!\n\nTesting!\n"; - -@ERRORS = (); -@WARNINGS = (); - -mail2node('/dummy/file'); -ok( join( "", @ERRORS ) =~ /mail2node\: Node creation of type mail failed\!/, - "Throw an error if mail2node creation directive fails" ); - -$m2n_node->set_always( "getMe", $m2n_node ); - -$m2n_node->{type_nodetype} = 5; #fake mail nodetype - -untie *Everything::Mail::FILE; -tie *Everything::Mail::FILE, 'MockHandle', -"To: foo\@bar.com\nFrom: testing\@test.com\nSubject: this is a test email!\n\nTesting!\nHello\n"; -@ERRORS = (); -@WARNINGS = (); -$m2n_node->clear(); -mail2node('/dummy/file'); -$m2n_node->called_ok( "insert", "mail2node calls insert" ); -is( $m2n_node->call_pos(2), "insert", "insert gets called in the right spot" ); -is( $m2n_node->call_args_pos( 2, 2 ), - "-1", "insert gets called without permissions (-1)" ); -is( - $m2n_node->{title}, - "this is a test email!", - "...and the subject gets set correctly" -); -is( $m2n_node->{from_address}, - "testing\@test.com", "...and the from_address gets set correctly" ); -is( $m2n_node->{doctext}, "\nTesting!\nHello\n", - "...and the doctext gets set correctly" ); -is( $m2n_node->{author_user}, - "5", "...and gets the (faked) root_id correctly!" ); - -$m2n_user->set_always( "getMe", $m2n_user ); - -$m2n_user->{node_id} = 24; -$m2n_user->{title} = "not root"; - -untie *Everything::Mail::FILE; -tie *Everything::Mail::FILE, 'MockHandle', -"To: foo\@bar.com\nFrom: testing\@test.com\nSubject: this is a test email!\n\nTesting!\nHello\n"; -@ERRORS = (); -@WARNINGS = (); -$m2n_node->clear(); - -mail2node('/dummy/file'); -$m2n_node->called_ok( "insert", - "mail2node calls insert when it can get the user" ); -is( $m2n_node->{author_user}, "24", "...and has the correct (faked) id" ); - -############################### -# Tests left: -############################### -# See what happens if Mail::Address returns null -# Badly formed email addresses -# Have hard limit of size of email (size of doctext) -# Make sure multiple files works This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-09-29 08:03:24
|
Revision: 913 http://svn.sourceforge.net/everydevel/?rev=913&view=rev Author: paul_the_nomad Date: 2006-09-29 01:02:39 -0700 (Fri, 29 Sep 2006) Log Message: ----------- Unit tests for Everything.pm plus moving abstract class to Test/Abstract.pm Modified Paths: -------------- trunk/ebase/lib/Everything/Test/Auth.pm trunk/ebase/lib/Everything/Test/CacheQueue.pm trunk/ebase/lib/Everything/Test/Mail.pm trunk/ebase/lib/Everything/Test/NodeCache.pm trunk/ebase/lib/Everything/Test/Security.pm trunk/ebase/lib/Everything/Test/Util.pm trunk/ebase/lib/Everything/Test/XML.pm trunk/ebase/t/Everything.t Added Paths: ----------- trunk/ebase/lib/Everything/Test/Abstract.pm trunk/ebase/lib/Everything/Test.pm Removed Paths: ------------- trunk/ebase/lib/Everything/Test.pm Copied: trunk/ebase/lib/Everything/Test/Abstract.pm (from rev 908, trunk/ebase/lib/Everything/Test.pm) =================================================================== --- trunk/ebase/lib/Everything/Test/Abstract.pm (rev 0) +++ trunk/ebase/lib/Everything/Test/Abstract.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -0,0 +1,29 @@ +package Everything::Test::Abstract; + +use Scalar::Util 'blessed'; +use SUPER; +use Test::More; + +use base 'Test::Class'; + + + +sub module_class +{ + my $self = shift; + my $name = blessed( $self ); + $name =~ s/Test:://; + return $name; +} + + +sub startup :Test( startup => 1 ) +{ + my $self = shift; + my $module = $self->module_class(); + use_ok( $module ) or exit; + $self->{class} = $self->module_class; + +} + +1; Modified: trunk/ebase/lib/Everything/Test/Auth.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Auth.pm 2006-09-25 13:10:14 UTC (rev 912) +++ trunk/ebase/lib/Everything/Test/Auth.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -1,6 +1,6 @@ package Everything::Test::Auth; -use base 'Everything::Test'; +use base 'Everything::Test::Abstract'; use Test::More; use Test::Exception; use Test::MockObject; Modified: trunk/ebase/lib/Everything/Test/CacheQueue.pm =================================================================== --- trunk/ebase/lib/Everything/Test/CacheQueue.pm 2006-09-25 13:10:14 UTC (rev 912) +++ trunk/ebase/lib/Everything/Test/CacheQueue.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -1,6 +1,6 @@ package Everything::Test::CacheQueue; -use base 'Everything::Test'; +use base 'Everything::Test::Abstract'; use Test::More; use Test::MockObject; use strict; Modified: trunk/ebase/lib/Everything/Test/Mail.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Mail.pm 2006-09-25 13:10:14 UTC (rev 912) +++ trunk/ebase/lib/Everything/Test/Mail.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -1,6 +1,6 @@ package Everything::Test::Mail; -use base 'Everything::Test'; +use base 'Everything::Test::Abstract'; use Test::More; use Test::MockObject; use File::Spec; Modified: trunk/ebase/lib/Everything/Test/NodeCache.pm =================================================================== --- trunk/ebase/lib/Everything/Test/NodeCache.pm 2006-09-25 13:10:14 UTC (rev 912) +++ trunk/ebase/lib/Everything/Test/NodeCache.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -3,7 +3,7 @@ use Test::More; use Test::MockObject; use Scalar::Util qw/blessed/; -use base 'Everything::Test'; +use base 'Everything::Test::Abstract'; use strict; use warnings; Modified: trunk/ebase/lib/Everything/Test/Security.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Security.pm 2006-09-25 13:10:14 UTC (rev 912) +++ trunk/ebase/lib/Everything/Test/Security.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -1,6 +1,6 @@ package Everything::Test::Security; -use base 'Everything::Test'; +use base 'Everything::Test::Abstract'; use Test::More; Modified: trunk/ebase/lib/Everything/Test/Util.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Util.pm 2006-09-25 13:10:14 UTC (rev 912) +++ trunk/ebase/lib/Everything/Test/Util.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -1,6 +1,6 @@ package Everything::Test::Util; -use base 'Everything::Test'; +use base 'Everything::Test::Abstract'; use Test::More; use strict; Modified: trunk/ebase/lib/Everything/Test/XML.pm =================================================================== --- trunk/ebase/lib/Everything/Test/XML.pm 2006-09-25 13:10:14 UTC (rev 912) +++ trunk/ebase/lib/Everything/Test/XML.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -5,7 +5,7 @@ use Test::MockObject; use SUPER; -use base 'Everything::Test'; +use base 'Everything::Test::Abstract'; sub startup : Test(startup => +0) { my $self = shift; Deleted: trunk/ebase/lib/Everything/Test.pm =================================================================== --- trunk/ebase/lib/Everything/Test.pm 2006-09-25 13:10:14 UTC (rev 912) +++ trunk/ebase/lib/Everything/Test.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -1,29 +0,0 @@ -package Everything::Test; - -use Scalar::Util 'blessed'; -use SUPER; -use Test::More; - -use base 'Test::Class'; - - - -sub module_class -{ - my $self = shift; - my $name = blessed( $self ); - $name =~ s/Test:://; - return $name; -} - - -sub startup :Test( startup => 1 ) -{ - my $self = shift; - my $module = $self->module_class(); - use_ok( $module ) or exit; - $self->{class} = $self->module_class; - -} - -1; Added: trunk/ebase/lib/Everything/Test.pm =================================================================== --- trunk/ebase/lib/Everything/Test.pm (rev 0) +++ trunk/ebase/lib/Everything/Test.pm 2006-09-29 08:02:39 UTC (rev 913) @@ -0,0 +1,491 @@ +package Everything::Test; + +use base 'Everything::Test::Abstract'; +use Scalar::Util 'blessed'; +use TieOut; +use Test::More; +use Test::MockObject; +use File::Spec; +use File::Temp; +use IO::File; +use SUPER; +use strict; +use warnings; + +BEGIN { + + ## This is required because Everything.pm reads the log file name + ## from %ENV and copies it to a lexical. So we need to set it up + ## %ENV before Everything.pm is 'required'. Everything.pm + ## effectively creates a closure and we can no longer access the + ## log file name. + + ## XXXX - This "feature" must be changed so we can amend the log + ## file at run time, preferably in a way that uses encapsulation + ## properly, i.e. using methods. + + ## THIS + my $tmpdir = File::Spec->tmpdir; + my $fh = File::Temp->new( + TEMPLATE => $$ . 'XXXXXXX', + DIR => $tmpdir, + UNLINK => 0 + ); + my $fname = $fh->filename; + $ENV{EVERYTHING_LOG} = $fname; + + $fh->close; + +} + +BEGIN { + ## needed so we can override CORE subs. + *Everything::gmtime = sub { CORE::gmtime }; + *Everything::caller = sub { }; +} + +sub module_class { + my $self = shift; + my $name = blessed($self); + $name =~ s/::Test//; + return $name; +} + +sub test_imported_subs : Test(7) { + my $self = shift; + + for my $sub ( + qw( + getNode getNodeById getType getNodeWhere selectNodeWhere getRef getId ) + ) + { + can_ok( $self->{class}, $sub ); + } + +} + +sub test_getTime : Test(2) { + my $self = shift; + + local *Everything::gmtime = + sub { return wantarray ? ( 0 .. 6 ) : 'long time' }; + is( + Everything::getTime(), + '1905-05-03 02:01:00', + 'getTime() should format gmtime output nicely' + ); + is( Everything::getTime(1), 'long time', + '... respecting the long flag, if passed' ); + +} + +sub test_getParamArray : Test(5) { + my $self = shift; + no strict 'refs'; + + local *{ __PACKAGE__ . '::getParamArray' } = + \&{ $self->{class} . '::getParamArray' }; + my $order = 'red, blue, one , two'; + my @results = getParamArray( $order, qw( one two red blue ) ); + my @args = ( -one => 1, -two => 2, -red => 'red', -blue => 'blue' ); + is( @results, 4, 'getParamArray() should return array params unchanged' ); + + @results = getParamArray( $order, @args ); + is( @results, 4, '... and the right number of args in hash mode' ); + + # now ask for a repeated parameter + @results = getParamArray( $order . ', one', @args ); + is( @results, 5, '... (even when being tricky)' ); + is( join( '', @results ), 'redblue121', '... the values in hash mode' ); + + # and leave out some parameters + is( join( '', getParamArray( 'red,blue', @args ) ), + 'redblue', '... and only the requested values' ); +} + +sub test_cleanLinks : Test(3) { + my $self = shift; + + my $mock = Test::MockObject->new(); + $mock->set_always( 'sqlSelectJoined', $mock )->set_series( + 'fetchrow_hashref', + { node_id => 1 }, + { to_node => 8 }, + 0, + { node_id => 2, to_node => 9 }, + { to_node => 10 } + )->set_true('sqlDelete'); + + local *Everything::DB; + *Everything::DB = \$mock; + + Everything::cleanLinks(); + + my @expect = ( to_node => 8, from_node => 10 ); + my $count; + + while ( my ( $method, $args ) = $mock->next_call() ) { + next unless $method eq 'sqlDelete'; + my $args = join( '-', $args->[1], $args->[2]->{ shift @expect } ); + is( + $args, + 'links-' . shift @expect, + 'cleanLink() should delete bad links' + ); + $count++; + } + + is( $count, 2, '... and only bad links' ); +} + +sub test_initEverything : Test(8) + +{ + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::initEverything' } = + \&{ $self->{class} . '::initEverything' }; + use strict 'refs'; + no warnings qw/redefine once/; + local @Everything::fsErrors = '123'; + local @Everything::bsErrors = '321'; + local ( $Everything::DB, %Everything::NODEBASES ); + my $db = Test::MockObject->new; + $db->fake_module('Everything::DB::mysql'); + + local *Everything::NodeBase::getType = sub { 0 }; + local *Everything::NodeBase::buildNodetypeModules = sub { undef }; + + $db->fake_new('Everything::DB::mysql'); + $db->set_true( 'databaseConnect', 'getNodeByIdNew', 'getNodeByName' ); + initEverything( 'onedb', { staticNodetypes => 1 } ); + isa_ok( $Everything::DB, 'Everything::NodeBase' ); + is( @Everything::fsErrors, 0, '... and should clear @fsErrors' ); + is( @Everything::bsErrors, 0, '... and @bsErrors' ); + + initEverything('onedb'); + is( + $Everything::DB, + $Everything::NODEBASES{onedb}, + '... should reuse NodeBase object with same DB requested' + ); + + initEverything('twodb'); + is( keys %Everything::NODEBASES, 2, '... and should cache objects' ); + + eval { initEverything( 'threedb', { dbtype => 'badtype' } ) }; + like( + $@, + qr/Unknown database type 'badtype'/, + '... dying given bad dbtype' + ); + + my $status; + local @INC = 'lib'; + + @INC = 'lib'; + $db->fake_module('Everything::DB::foo'); + $db->fake_new('Everything::DB::foo'); + + eval { initEverything( 'foo', { dbtype => 'foo' } ) }; + is( $@, '', '... loading nodebase for requested database type' ); + ok( exists $Everything::NODEBASES{foo}, '... and caching it' ); +} + +sub test_clearFrontside : Test(1) + +{ + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::clearFrontside' } = + \&{ $self->{class} . '::clearFrontside' }; + use strict 'refs'; + + local @Everything::fsErrors = '123'; + clearFrontside(); + is( @Everything::fsErrors, 0, 'clearFrontside() should clear @fsErrors' ); +} + +sub test_clearBackside : Test(1) { + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::clearBackside' } = + \&{ $self->{class} . '::clearBackside' }; + use strict 'refs'; + + local @Everything::bsErrors = '123'; + clearBackside(); + is( @Everything::bsErrors, 0, 'clearBackside() should clear @bsErrors' ); +} + +sub test_logHash : Test(4) { + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::logHash' } = \&{ $self->{class} . '::logHash' }; + use strict 'refs'; + + my $log; + local *Everything::printLog; + *Everything::printLog = sub { + $log .= join( '', @_ ); + }; + + my $hash = { foo => 'bar', boo => 'far' }; + ok( logHash($hash), 'logHash() should succeed' ); + + # must quote the parenthesis in the stringified references + like( $log, qr/\Q$hash\E/, '... and should log hash reference' ); + like( $log, qr/foo = bar/, '... and hash keys' ); + like( $log, qr/boo = far/, '... and hash keys (redux)' ); +} + +sub test_callLogStack : Test(2) { + + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::logCallStack' } = + \&{ $self->{class} . '::logCallStack' }; + use strict 'refs'; + + my $log; + local *Everything::printLog; + *Everything::printLog = sub { + $log .= join( '', @_ ); + }; + + local *Everything::getCallStack; + *Everything::getCallStack = sub { + return ( 1 .. 10 ); + }; + + Everything::logCallStack(); + like( $log, qr/^Call Stack:/, 'logCallStack() should print log' ); + like( $log, qr/9.8.7/s, + '... and should report stack backwards, minus first element' ); +} + +sub test_getCallStack_dumpCallStack : Test(6) { + my $self = shift; + local *Everything::caller = sub { + my $frame = shift; + return if $frame >= 5; + return ( 'Everything', 'everything.t', 100 + $frame, $frame, + $frame % 2 ); + }; + + my @stack = Everything::getCallStack(); + is( @stack, 4, 'getCallStack() should not report self' ); + + is( $stack[0], 'everything.t:104:4', + '... should report file, line, subname' ); + is( $stack[-1], 'everything.t:101:1', + '... and report frames in reverse order' ); + local *STDOUT; + my $out = tie *STDOUT, 'TieOut'; + Everything::dumpCallStack(); + + my $stackdump = $out->read(); + like( $stackdump, qr/Start/, 'dumpCallStack() should print its output' ); + like( $stackdump, qr/102:2.+103:3.+104:4/s, + '... should report stack in forward order' ); + ok( $stackdump !~ /101/, '... but should remove current frame' ); +} + +sub test_printErr : Test(2) { + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::printErr' } = \&{ $self->{class} . '::printErr' }; + use strict 'refs'; + + local *STDERR; + my $out = tie *STDERR, 'TieOut'; + printErr('error message'); + is( $out->read, 'error message', 'printErr() should print to STDERR' ); + printErr( 7, 6, 5 ); + is( $out->read, 7, '... and only the first parameter' ); +} + +sub test_logErrors : Test(7) { + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::logErrors' } = + \&{ $self->{class} . '::logErrors' }; + use strict 'refs'; + + local *STDOUT; + my $out = tie *STDOUT, 'TieOut'; + is( logErrors(), undef, + 'logErrors() should return, lacking passed a warning or an error' ); + + local $Everything::commandLine = 0; + ok( + logErrors( 'warning', undef, 'code', 'CONTEXT' ), + '... and should succeed given a warning or an error' + ); + + is( join( '', sort values %{ $Everything::fsErrors[-1] } ), + 'CONTEXTcodewarning', + '... should store message in @fsErrors normally' ); + logErrors( undef, 'error', 'code', 'CONTEXT' ); + is( join( '', sort values %{ $Everything::fsErrors[-1] } ), + 'CONTEXTcodeerror', + '... should use blank string lacking a warning or error' ); + is( $$out, undef, '... and should not print unless $commandLine is true' ); + + $Everything::commandLine = 1; + logErrors( 'warn', 'error', 'code' ); + my $output = $out->read(); + + like( $output, qr/^###/, '... should print if $commandLine is true' ); + like( + $output, + qr/Warning: warn.+Error: error.+Code: code/s, + '... should print warning, error, and code' + ); +} + +sub test_flushErrorsToBackside : Test(4) { + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::flushErrorsToBackside' } = + \&{ $self->{class} . '::flushErrorsToBackside' }; + + local *{ __PACKAGE__ . '::getFrontsideErrors' } = + \&{ $self->{class} . '::getFrontsideErrors' }; + local *{ __PACKAGE__ . '::getBacksideErrors' } = + \&{ $self->{class} . '::getBacksideErrors' }; + use strict 'refs'; + + local ( @Everything::fsErrors, @Everything::bsErrors ); + + @Everything::fsErrors = ( 1 .. 3 ); + @Everything::bsErrors = 'a'; + + flushErrorsToBackside(); + is( join( '', @Everything::bsErrors ), + 'a123', + 'flushErrorsToBackside() should push @fsErrors onto @bsErrors' ); + is( @Everything::fsErrors, 0, '... should clear @fsErrors' ); + + is( getFrontsideErrors(), \@Everything::fsErrors, + 'getFrontsideErrors() should return reference to @fsErrors' ); + is( getBacksideErrors(), \@Everything::bsErrors, + 'getBacksideErrors() should return reference to @bsErrors' ); +} + +sub test_searchNodeName : Test(12) { + my $self = shift; + local $Everything::DB = Test::MockObject->new; + my $mock = Test::MockObject->new; + my $quotes; + my $id = []; + my @calls; + my $fake_nodes = { foo => 1, bar => 2 }; + $Everything::DB->mock( + 'getId', + sub { + push @$id, $fake_nodes->{ $_[1] }; + return $fake_nodes->{ $_[1] }; + } + )->set_always( 'getNode', $mock ) + ->set_always( 'getDatabaseHandle', $mock )->mock( + 'sqlSelectMany', + sub { push @calls, [ 'sqlSelectMany', @_ ]; $mock } + ); + + $mock->mock( 'quote', sub { my $r = qq{'$_[1]'}; $quotes .= $r; $r; } ); + $mock->set_series( 'fetchrow_hashref', 1, 2, 3 ); + + ## to test skipped words + $mock->set_always( getVars => { ab => 1, abcd => 1, } ); + + is( Everything::searchNodeName(''), + undef, + 'searchNodeName() should return without workable words to find' ); + + Everything::searchNodeName( '', [ 'foo', 'bar' ] ); + is( $id->[0], 1, '... should call getId() for first type' ); + is( $id->[1], 2, + '... should call getId() for subsequent types (if passed)' ); + + Everything::searchNodeName('quote'); + is( $quotes, q{'[[:<:]]quote[[:>:]]'}, + '... should quote() searchable words' ); + + # reset series + $mock->set_series( 'fetchrow_hashref', 1, 2, 3 ); + + my $found = + Everything::searchNodeName( 'ab aBc! abcd a ee', [ 'foo', 'bar' ] ); + + like( $quotes, qr/abc\\!/, '... should escape nonword chars too' ); + + is( $calls[-1]->[0], 'sqlSelectMany', + '... should sqlSelectMany() matching titles' ); + like( + $calls[-1]->[2], + qr/\*.+?lower.title.+?rlike.+abc.+/, + '... selecting by title with regexes' + ); + + like( + $calls[-1]->[4], + qr/AND .type_nodetype = 1 OR type_nodetype = 2/, + '... should constrain by type, if provided' + ); + is( + $calls[-1]->[5], + 'ORDER BY matchval DESC', + '... and should order results properly' + ); + + is( ref $found, 'ARRAY', '... should return an arrayref on success' ); + + is( @$found, 3, '... should find all proper results' ); + is( join( '', @$found ), '123', '... and should return results' ); +} + +sub test_clearLog : Test(4) { + my $self = shift; + local *Everything::getTime; + *Everything::getTime = sub { 'timestamp' }; + + my $log_file = $ENV{EVERYTHING_LOG}; + unlink 'log' if -e 'log'; + + Everything::printLog('logme'); + + my $fh = IO::File->new; + $fh->open($log_file) || return "log open failed, $!"; + + # 'printLog() should log to file specified in %ENV' ); + + my $line = <$fh>; + + is( $line, "timestamp: logme\n", '... logging time and message' ); + close $fh; + + Everything::printLog('second'); + $fh->open($log_file) or return "log open failed again, $!"; + + my @lines = <$fh>; + close $fh; + + is( $lines[1], "timestamp: second\n", '... appending to log' ); + + Everything::clearLog(); + + $fh->open($log_file) or return "log open failed on third try, $!"; + @lines = <$fh>; + + is( @lines, 1, 'clearLog() should clear old lines' ); + is( + $lines[0], + 'timestamp: Everything log cleared', + '... writing a cleared message' + ); + $fh->close; + unlink $log_file; +} + +1; Property changes on: trunk/ebase/lib/Everything/Test.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/t/Everything.t =================================================================== --- trunk/ebase/t/Everything.t 2006-09-25 13:10:14 UTC (rev 912) +++ trunk/ebase/t/Everything.t 2006-09-29 08:02:39 UTC (rev 913) @@ -2,394 +2,7 @@ use strict; use warnings; +use lib 't/lib'; +use Everything::Test; -BEGIN -{ - package Everything; - use subs qw( gmtime caller ); - - package main; - - chdir 't' if -d 't'; - use lib '../lib', 'lib'; - -} - -use TieOut; -use FakeDBI; -use File::Path; -use File::Spec; -use Test::More tests => 70; -use Test::MockObject; - -$ENV{EVERYTHING_LOG} = File::Spec->catfile( File::Spec->curdir(), 'log' ); -use_ok('Everything'); - -for my $sub ( qw( - getNode getNodeById getType getNodeWhere selectNodeWhere getRef getId ) - ) -{ - can_ok( 'main', $sub ); -} - -# printErr() -{ - local *STDERR; - my $out = tie *STDERR, 'TieOut'; - printErr('error message'); - is( $out->read, 'error message', 'printErr() should print to STDERR' ); - printErr( 7, 6, 5 ); - is( $out->read, 7, '... and only the first parameter' ); -} - -# getTime() -{ - local *Everything::gmtime; - *Everything::gmtime = sub { return wantarray ? ( 0 .. 6 ) : 'long time' }; - is( - Everything::getTime(), - '1905-05-03 02:01:00', - 'getTime() should format gmtime output nicely' - ); - is( Everything::getTime(1), 'long time', - '... respecting the long flag, if passed' ); -} - -# printLog() -# clearLog() -SKIP: -{ - local *Everything::getTime; - *Everything::getTime = sub { 'timestamp' }; - - unlink 'log' if -e 'log'; - - Everything::printLog('logme'); - - local *IN; - my $skip = ok( open( IN, 'log' ), - 'printLog() should log to file specified in %ENV' ); - - skip( 'log open failed', 4 ) unless $skip; - my $line = <IN>; - - is( $line, "timestamp: logme\n", '... logging time and message' ); - close IN; - - Everything::printLog('second'); - open( IN, 'log' ) or skip( 'log open failed again', 3 ); - - my @lines = <IN>; - close IN; - - is( $lines[1], "timestamp: second\n", '... appending to log' ); - - Everything::clearLog(); - - open( IN, 'log' ) or skip( 'log open failed on third try', 2 ); - @lines = <IN>; - - is( @lines, 1, 'clearLog() should clear old lines' ); - is( - $lines[0], - 'timestamp: Everything log cleared', - '... writing a cleared message' - ); - - unlink 'log'; -} - -# getParamArray() -my $order = 'red, blue, one , two'; -my @results = getParamArray( $order, qw( one two red blue ) ); -my @args = ( -one => 1, -two => 2, -red => 'red', -blue => 'blue' ); -is( @results, 4, 'getParamArray() should return array params unchanged' ); - -@results = getParamArray( $order, @args ); -is( @results, 4, '... and the right number of args in hash mode' ); - -# now ask for a repeated parameter -@results = getParamArray( $order . ', one', @args ); -is( @results, 5, '... (even when being tricky)' ); -is( join( '', @results ), 'redblue121', '... the values in hash mode' ); - -# and leave out some parameters -is( join( '', getParamArray( 'red,blue', @args ) ), - 'redblue', '... and only the requested values' ); - -# cleanLinks() -{ - my $mock = Test::MockObject->new(); - $mock->set_always( 'sqlSelectJoined', $mock )->set_series( - 'fetchrow_hashref', - { node_id => 1 }, - { to_node => 8 }, - 0, - { node_id => 2, to_node => 9 }, - { to_node => 10 } - )->set_true('sqlDelete'); - - local *Everything::DB; - *Everything::DB = \$mock; - - Everything::cleanLinks(); - - my @expect = ( to_node => 8, from_node => 10 ); - my $count; - - while ( my ( $method, $args ) = $mock->next_call() ) - { - next unless $method eq 'sqlDelete'; - my $args = join( '-', $args->[1], $args->[2]->{ shift @expect } ); - is( - $args, - 'links-' . shift @expect, - 'cleanLink() should delete bad links' - ); - $count++; - } - - is( $count, 2, '... and only bad links' ); -} - -# initEverything() - -{ - no warnings qw/redefine once/; - local @Everything::fsErrors = '123'; - local @Everything::bsErrors = '321'; - local ( $Everything::DB, %Everything::NODEBASES ); - my $db = Test::MockObject->new; - $db->fake_module('Everything::DB::mysql'); - - local *Everything::NodeBase::getType = sub {0}; - - $db->fake_new('Everything::DB::mysql'); - $db->set_true('databaseConnect', 'fetch_all_nodetype_names', 'getNodeByIdNew', 'getNodeByName'); - initEverything( 'onedb', { staticNodetypes => 1 } ); - isa_ok($Everything::DB, 'Everything::NodeBase'); - is( @Everything::fsErrors, 0, '... and should clear @fsErrors' ); - is( @Everything::bsErrors, 0, '... and @bsErrors' ); - - initEverything('onedb'); - is( $Everything::DB, $Everything::NODEBASES{onedb}, - '... should reuse NodeBase object with same DB requested' ); - - initEverything('twodb'); - is( keys %Everything::NODEBASES, 2, '... and should cache objects' ); - - eval { initEverything( 'threedb', { dbtype => 'badtype' } ) }; - like( - $@, - qr/Unknown database type 'badtype'/, - '... dying given bad dbtype' - ); - - my $status; - local @INC = 'lib'; - - @INC = 'lib'; - $db->fake_module('Everything::DB::foo'); - $db->fake_new('Everything::DB::foo'); - - eval { initEverything( 'foo', { dbtype => 'foo' } ) }; - is( $@, '', '... loading nodebase for requested database type' ); - ok( exists $Everything::NODEBASES{foo}, '... and caching it' ); -} - -# clearFrontside() -{ - local @Everything::fsErrors = '123'; - clearFrontside(); - is( @Everything::fsErrors, 0, 'clearFrontside() should clear @fsErrors' ); -} - -# clearBackside() -{ - local @Everything::bsErrors = '123'; - clearBackside(); - is( @Everything::bsErrors, 0, 'clearBackside() should clear @bsErrors' ); -} - -# logErrors() -{ - local *STDOUT; - my $out = tie *STDOUT, 'TieOut'; - is( logErrors(), undef, - 'logErrors() should return, lacking passed a warning or an error' ); - - local $Everything::commandLine = 0; - ok( - logErrors( 'warning', undef, 'code', 'CONTEXT' ), - '... and should succeed given a warning or an error' - ); - - is( join( '', sort values %{ $Everything::fsErrors[-1] } ), - 'CONTEXTcodewarning', - '... should store message in @fsErrors normally' ); - logErrors( undef, 'error', 'code', 'CONTEXT' ); - is( join( '', sort values %{ $Everything::fsErrors[-1] } ), - 'CONTEXTcodeerror', - '... should use blank string lacking a warning or error' ); - is( $$out, undef, '... and should not print unless $commandLine is true' ); - - $Everything::commandLine = 1; - logErrors( 'warn', 'error', 'code' ); - my $output = $out->read(); - - like( $output, qr/^###/, '... should print if $commandLine is true' ); - like( - $output, - qr/Warning: warn.+Error: error.+Code: code/s, - '... should print warning, error, and code' - ); -} - -# flushErrorsToBackside() -{ - local ( @Everything::fsErrors, @Everything::bsErrors ); - - @Everything::fsErrors = ( 1 .. 3 ); - @Everything::bsErrors = 'a'; - - flushErrorsToBackside(); - is( join( '', @Everything::bsErrors ), - 'a123', - 'flushErrorsToBackside() should push @fsErrors onto @bsErrors' ); - is( @Everything::fsErrors, 0, '... should clear @fsErrors' ); -} - -is( getFrontsideErrors(), \@Everything::fsErrors, - 'getFrontsideErrors() should return reference to @fsErrors' ); -is( getBacksideErrors(), \@Everything::bsErrors, - 'getBacksideErrors() should return reference to @bsErrors' ); - - # searchNodeName() - { - local $Everything::DB = Test::MockObject->new; - my $mock = Test::MockObject->new; - my $quotes; - my $id = []; - my @calls; - my $fake_nodes = { foo => 1, bar => 2}; - $Everything::DB->mock('getId', - sub { push @$id, $fake_nodes->{$_[1]}; - return $fake_nodes->{$_[1]} } - ) - ->set_always('getNode', $mock) - ->set_always('getDatabaseHandle', $mock) - ->mock('sqlSelectMany', - sub { push @calls, ['sqlSelectMany', @_ ]; $mock} - ); - - $mock->mock('quote', sub { my $r = qq{'$_[1]'}; $quotes .= $r; $r;}); - $mock->set_series('fetchrow_hashref', 1, 2, 3); - - ## to test skipped words - $mock->set_always( getVars => { ab => 1, abcd => 1, } ); - - - - is( Everything::searchNodeName(''), - undef, - 'searchNodeName() should return without workable words to find' ); - - - Everything::searchNodeName( '', [ 'foo', 'bar' ] ); - is ($id->[0], 1, '... should call getId() for first type' ); - is ($id->[1], 2, '... should call getId() for subsequent types (if passed)'); - - Everything::searchNodeName('quote'); - is( $quotes, q{'[[:<:]]quote[[:>:]]'}, '... should quote() searchable words' ); - - # reset series - $mock->set_series('fetchrow_hashref', 1, 2, 3); - - my $found = - Everything::searchNodeName( 'ab aBc! abcd a ee', [ 'foo', 'bar' ] ); - - - like( $quotes, qr/abc\\!/, '... should escape nonword chars too' ); - - is( $calls[-1]->[0], 'sqlSelectMany', - '... should sqlSelectMany() matching titles' ); - like( - $calls[-1]->[2], - qr/\*.+?lower.title.+?rlike.+abc.+/, - '... selecting by title with regexes' - ); - - like( - $calls[-1]->[4], - qr/AND .type_nodetype = 1 OR type_nodetype = 2/, - '... should constrain by type, if provided' - ); - is( - $calls[-1]->[5], - 'ORDER BY matchval DESC', - '... and should order results properly' - ); - - is( ref $found, 'ARRAY', '... should return an arrayref on success' ); - - is( @$found, 3, '... should find all proper results' ); - is( join( '', @$found ), '123', '... and should return results' ); - } - -# getCallStack() and dumpCallStack() -{ - local *Everything::caller = sub { - my $frame = shift; - return if $frame >= 5; - return ( 'Everything', 'everything.t', 100 + $frame, $frame, - $frame % 2 ); - }; - - my @stack = Everything::getCallStack(); - is( @stack, 4, 'getCallStack() should not report self' ); - is( $stack[0], 'everything.t:104:4', - '... should report file, line, subname' ); - is( $stack[-1], 'everything.t:101:1', - '... and report frames in reverse order' ); - - local *STDOUT; - my $out = tie *STDOUT, 'TieOut'; - Everything::dumpCallStack(); - - my $stackdump = $out->read(); - like( $stackdump, qr/Start/, 'dumpCallStack() should print its output' ); - like( $stackdump, qr/102:2.+103:3.+104:4/s, - '... should report stack in forward order' ); - ok( $stackdump !~ /101/, '... but should remove current frame' ); -} - -# this is handy for the other functions -my $log; -local *Everything::printLog; -*Everything::printLog = sub { - $log .= join( '', @_ ); -}; - -# logCallStack() -{ - local *Everything::getCallStack; - *Everything::getCallStack = sub { - return ( 1 .. 10 ); - }; - - Everything::logCallStack(); - like( $log, qr/^Call Stack:/, 'logCallStack() should print log' ); - like( $log, qr/9.8.7/s, - '... and should report stack backwards, minus first element' ); -} - -# logHash() -{ - my $hash = { foo => 'bar', boo => 'far' }; - ok( logHash($hash), 'logHash() should succeed' ); - - # must quote the parenthesis in the stringified references - like( $log, qr/\Q$hash\E/, '... and should log hash reference' ); - like( $log, qr/foo = bar/, '... and hash keys' ); - like( $log, qr/boo = far/, '... and hash keys (redux)' ); -} +Everything::Test->runtests; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-09-29 15:33:00
|
Revision: 914 http://svn.sourceforge.net/everydevel/?rev=914&view=rev Author: paul_the_nomad Date: 2006-09-29 08:32:16 -0700 (Fri, 29 Sep 2006) Log Message: ----------- Tests for FormObject.pm Modified Paths: -------------- trunk/ebase/lib/Everything/Test/Abstract.pm Added Paths: ----------- trunk/ebase/lib/Everything/HTML/Test/ trunk/ebase/lib/Everything/HTML/Test/FormObject.pm trunk/ebase/t/HTML/FormObject.t Added: trunk/ebase/lib/Everything/HTML/Test/FormObject.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/Test/FormObject.pm (rev 0) +++ trunk/ebase/lib/Everything/HTML/Test/FormObject.pm 2006-09-29 15:32:16 UTC (rev 914) @@ -0,0 +1,213 @@ +package Everything::HTML::Test::FormObject; + +use Test::More; +use Test::MockObject; +use Test::MockObject::Extends; +use base 'Everything::Test::Abstract'; +use Scalar::Util qw/blessed/; +use CGI; +use SUPER; +use base 'Test::Class'; +use strict; +use warnings; + +sub startup : Test(startup => +0) { + my $self = shift; + + # Unfortunately this imports stuff from Everything.pm. + my $mock = Test::MockObject->new; + $mock->fake_module('Everything'); + my $module = $self->module_class(); + no strict 'refs'; + *{ $module . '::DB' } = \$mock; + use strict 'refs'; + use_ok($module) or exit; + $self->{class} = $module; + $self->{mock} = $mock; + +} + +sub test_new : Test(startup => 3) { + my $self = shift; + my $instance = $self->{class}->new; + isa_ok( $instance, $self->{class} ); + ( my $object_name ) = $self->{class} =~ /::(\w+)$/; + is( $instance->{objectName}, + $object_name, '...the object name should be correct.' ); + is( $instance->{updateExecuteOrder}, + 50, '...with the update execute order properly set.' ); + +} + +sub fixture : Test(setup) { + my $self = shift; + $self->{instance} = $self->{class}->new; + $self->{node} = Test::MockObject->new; +} + +sub test_gen_bind_field : Test(3) { + my $self = shift; + my $instance = $self->{instance}; + my $cgi = CGI->new; + my $node = $self->{node}; + can_ok( $self->{class}, 'genBindField' ); + + ## Test no $node passed + is( $instance->genBindField( $cgi, undef ), + '', '...should return an empty string with no node object' ); + + ## passing a node and field + $node->{node_id} = 222; + is( + $instance->genBindField( $cgi, $node, 'foo', 'foobar' ), +'<input type="hidden" name="formbind_FormObject_foobar" value="50:222:foo" />', + '...should return html' + ); +} + +sub test_gen_object : Test(2) { + my $self = shift; + my $instance = $self->{instance}; + ## we are assuming that Everything::getParamArray behaves as advertised + no strict 'refs'; + my $cgi = CGI->new; + local *{ $self->{class} . '::getParamArray' } = sub { $cgi, @_ }; + use strict 'refs'; + can_ok( $self->{class}, 'genObject' ); + is( + $instance->genObject(qw/one two three/), +'<input type="hidden" name="formbind_FormObject_two" value="50::one" />', + '...returns html.' + ); + +} + +sub test_cgi_verify : Test(4) { + my $self = shift; + my $mock = $self->{mock}; + my $node = $self->{node}; + can_ok( $self->{class}, 'cgiVerify' ) || return "Can't cgiVerify"; + my $instance = Test::MockObject::Extends->new( $self->{instance} ); + $instance->set_series( 'getBindNode', undef, $node, $node ); + is_deeply( $instance->cgiVerify, {}, + '...should return empty array if can\'t retrieve a node' ); + + $node->set_series( 'hasAccess', 0, 1 ); + $node->set_always( 'getId', 222 ); + is_deeply( + $instance->cgiVerify, + { node => 222, failed => 'User does not have permission' }, +'...should return a hash with failure measure, if user does not have permission' + ); + is_deeply( + $instance->cgiVerify, + { node => 222 }, + '...should return a hash with node id, if user has permission.' + ); +} + +sub test_cgi_update : Test(13) { + my $self = shift; + can_ok( $self->{class}, 'cgiUpdate' ) || return "Can't cgiUpdate"; + + my $instance = Test::MockObject::Extends->new( $self->{instance} ); + $instance->set_always( 'getBindField', 'foo' ); + + my $cgi = CGI->new; + $cgi->param( 'foo', 'bar' ); + + my $node = $self->{node}; + $node->set_series( 'verifyFieldUpdate', 0, 1, 1, 1, 1 ); + + ## permission denied tests + is( $instance->cgiUpdate( $cgi, 'foo', $node ), + 0, '...returns 0 if update permission denied' ); + my ( $method, $args ) = $node->next_call; + is( $method, 'verifyFieldUpdate', '...and calls verifyFieldUpdate' ); + + ## permission allowed tests + + is( $instance->cgiUpdate( $cgi, 'foo', $node ), + 1, '...returns 1 if update permission allowed' ); + + ( $method, $args ) = $node->next_call; + + is( $method, 'verifyFieldUpdate', '...and calls verifyFieldUpdate' ); + is( $node->{foo}, 'bar', '...and sets foo to bar' ); + + ## tests with vars + delete $$node{foo}; + $node->set_always( 'getHash', { one => 'two' } ); + $node->set_true('setHash'); + $instance->set_always( 'getBindField', 'attribute_name::var_name' ); + is( $instance->cgiUpdate( $cgi, 'foo', $node ), + 1, '...returns 1 if update permission allowed' ); + ( $method, $args ) = $node->next_call; + is( $method, 'verifyFieldUpdate', '...again checks permissions' ); + ( $method, $args ) = $node->next_call; + is( $method, 'getHash', + '....should call getHash when updating a node with vars.' ); + is( $args->[1], 'attribute_name', + '....should pass field name to getHash.' ); + + ( $method, $args ) = $node->next_call; + is( $method, 'setHash', '...then calls setHash' ); + + is_deeply( + $args->[1], + { one => 'two', 'var_name' => 'bar' }, + '...with a hash argument.' + ); + is( $args->[2], 'attribute_name', + '...with the second argument the field name' ); + +} + +sub test_get_bind_node : Test(7) { + my $self = shift; + can_ok( $self->{class}, 'getBindNode' ) + || return "getBindNode not implemented."; + my $instance = $self->{instance}; + my $node = $self->{node}; + my $mock = $self->{mock}; # mock was setup in startup + $mock->set_always( 'getNode', $node ); + my $cgi = CGI->new; + $cgi->param( 'formbind_' . $instance->{objectName} . '_' . 'foo', + '50:bar:' ); + is( $instance->getBindNode( $cgi, 'foo' ), + $node, '...returns a node object.' ); + my ( $method, $args ) = $mock->next_call; + is( $method, 'getNode', '...should call getNode.' ); + is( $args->[1], 'bar', '...with a node_id.' ); + + ## test new fields + $cgi->param( 'formbind_' . $instance->{objectName} . '_' . 'foo', + '50:new:' ); + $cgi->param( 'node_id', 999 ); + $mock->clear; + is( $instance->getBindNode( $cgi, 'foo' ), + $node, '...returns a node object again.' ); + ( $method, $args ) = $mock->next_call; + is( $method, 'getNode', '...should call getNode.' ); + is( $args->[1], 999, '...with a node_id taken from the cgi object.' ); + +} + +sub test_get_bind_field : Test(3) { + my $self = shift; + can_ok( $self->{class}, 'getBindField' ) + || return "getBindField not implemented."; + + my $instance = $self->{instance}; + my $cgi = CGI->new; + is( $instance->getBindField( $cgi, 'gale' ), + undef, '...returns undef if no field exists.' ); + + $cgi->param( 'formbind_' . $instance->{objectName} . '_' . 'grah', + '40:foo:blah' ); + is( $instance->getBindField( $cgi, 'grah' ), + 'blah', '...otherwise returns the field name.' ); + +} + +1; Property changes on: trunk/ebase/lib/Everything/HTML/Test/FormObject.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/lib/Everything/Test/Abstract.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Abstract.pm 2006-09-29 08:02:39 UTC (rev 913) +++ trunk/ebase/lib/Everything/Test/Abstract.pm 2006-09-29 15:32:16 UTC (rev 914) @@ -22,7 +22,7 @@ my $self = shift; my $module = $self->module_class(); use_ok( $module ) or exit; - $self->{class} = $self->module_class; + $self->{class} = $module; } Added: trunk/ebase/t/HTML/FormObject.t =================================================================== --- trunk/ebase/t/HTML/FormObject.t (rev 0) +++ trunk/ebase/t/HTML/FormObject.t 2006-09-29 15:32:16 UTC (rev 914) @@ -0,0 +1,5 @@ +#! perl + +use Everything::HTML::Test::FormObject; + +Everything::HTML::Test::FormObject->runtests; Property changes on: trunk/ebase/t/HTML/FormObject.t ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-09-30 12:49:12
|
Revision: 916 http://svn.sourceforge.net/everydevel/?rev=916&view=rev Author: paul_the_nomad Date: 2006-09-30 05:48:23 -0700 (Sat, 30 Sep 2006) Log Message: ----------- Moving more tests for FormObjects Modified Paths: -------------- trunk/ebase/lib/Everything/HTML/FormObject/Test/ListMenu.pm trunk/ebase/t/HTML/FormObject/NodetypeMenu.t trunk/ebase/t/HTML/FormObject/TypeMenu.t Added Paths: ----------- trunk/ebase/lib/Everything/HTML/FormObject/Test/FormMenu.pm trunk/ebase/lib/Everything/HTML/FormObject/Test/NodetypeMenu.pm trunk/ebase/lib/Everything/HTML/FormObject/Test/TypeMenu.pm trunk/ebase/t/HTML/FormObject/FormMenu.t Added: trunk/ebase/lib/Everything/HTML/FormObject/Test/FormMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/Test/FormMenu.pm (rev 0) +++ trunk/ebase/lib/Everything/HTML/FormObject/Test/FormMenu.pm 2006-09-30 12:48:23 UTC (rev 916) @@ -0,0 +1,152 @@ +package Everything::HTML::FormObject::Test::FormMenu; + +use base 'Everything::HTML::Test::FormObject'; +use Test::More; +use Scalar::Util qw/blessed/; +use base 'Test::Class'; +use strict; +use warnings; + + + +sub setup_globals { + my $self = shift; + $self->SUPER; + no strict 'refs'; + *{ $self->package_under_test(__PACKAGE__) . '::DB' } = \$self->{mock}; + use strict 'refs'; + +} + +sub test_get_values_array : Test(3) +{ + my $self = shift; + can_ok($self->{class}, 'getValuesArray') || return 'getValuesArray not implemented.'; + my $instance = $self->{instance}; + is_deeply ($instance->getValuesArray, [], '...should return and empty array ref if no values.'); + + my $values = [qw/one two/]; + $instance->{VALUES} = $values; + is_deeply ($instance->getValuesArray, $values, '...should return the VALUES attribute if exists.'); + + +} + +sub test_get_labels_hash : Test(3) +{ + my $self = shift; + can_ok($self->{class}, 'getLabelsHash') || return 'getLabelsHash not implemented.'; + my $instance = $self->{instance}; + is_deeply ($instance->getLabelsHash, {}, '...should return and empty stringif no values.'); + + my $values = {one => 'two'}; + $instance->{LABELS} = $values; + is_deeply ($instance->getLabelsHash, $values, '...should return the LABELS attribute if exists.'); + + +} + +sub test_clear_menu : Test(3) +{ + my $self = shift; + can_ok($self->{class}, 'clearMenu') || return 'clearMenu not implemented.'; + my $instance = $self->{instance}; + $instance->{VALUES} = [qw/one two three/]; + $instance->{LABELS} = {four => 'five'}; + $instance->clearMenu; + is_deeply($instance->{VALUES}, [], '...should clear VALUES array ref'); + is_deeply($instance->{LABELS}, {}, '...should clear LABELS hash ref'); + +} + +sub test_sort_menu : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'sortMenu') || return 'sortMenu not implemented.'; + my $instance = $self->{instance}; + + +} + +sub test_remove_items : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'removeItems') || return 'removeItems not implemented.'; + my $instance = $self->{instance}; + + +} + +sub test_add_type : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'addType') || return 'addType not implemented.'; + my $instance = $self->{instance}; + + +} + +sub test_add_group : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'addGroup') || return 'addGroup not implemented.'; + my $instance = $self->{instance}; + + +} + +sub test_add_hash : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'addHash') || return 'addHash not implemented.'; + my $instance = $self->{instance}; + + +} + +sub test_add_array : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'addArray') || return 'addArray not implemented.'; + my $instance = $self->{instance}; + + +} + +sub test_add_labels : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'addLabels') || return 'addLabels not implemented.'; + my $instance = $self->{instance}; + + +} + +sub test_gen_popup_menu : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'genPopupMenu') || return 'genPopupMenu not implemented.'; + my $instance = $self->{instance}; + + +} + +sub test_gen_list_menu : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'genListMenu') || return 'genListMenu not implemented.'; + my $instance = $self->{instance}; + + +} + +sub test_gen_object : Test(1) +{ + my $self = shift; + can_ok($self->{class}, 'genObject') || return 'genObject not implemented.'; + my $instance = $self->{instance}; + + +} + +1; Property changes on: trunk/ebase/lib/Everything/HTML/FormObject/Test/FormMenu.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/lib/Everything/HTML/FormObject/Test/ListMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/Test/ListMenu.pm 2006-09-30 09:59:58 UTC (rev 915) +++ trunk/ebase/lib/Everything/HTML/FormObject/Test/ListMenu.pm 2006-09-30 12:48:23 UTC (rev 916) @@ -1,6 +1,6 @@ package Everything::HTML::FormObject::Test::ListMenu; -use base 'Everything::HTML::Test::FormObject'; +use base 'Everything::HTML::FormObject::Test::FormMenu'; use Test::More; use Test::MockObject; use Test::MockObject::Extends; @@ -9,15 +9,6 @@ use warnings; use strict; -sub setup_globals { - my $self = shift; - $self->SUPER; - no strict 'refs'; - *{'Everything::HTML::FormObject::FormMenu::DB'} = \$self->{mock}; - use strict 'refs'; - -} - sub test_cgi_update : Test(11) { my $self = shift; my $instance = Test::MockObject::Extends->new( $self->{instance} ); Added: trunk/ebase/lib/Everything/HTML/FormObject/Test/NodetypeMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/Test/NodetypeMenu.pm (rev 0) +++ trunk/ebase/lib/Everything/HTML/FormObject/Test/NodetypeMenu.pm 2006-09-30 12:48:23 UTC (rev 916) @@ -0,0 +1,268 @@ +package Everything::HTML::FormObject::Test::NodetypeMenu; + +use base 'Everything::HTML::FormObject::Test::TypeMenu'; +use Test::MockObject::Extends; +use Test::MockObject; +use Test::More; +use Scalar::Util qw/blessed/; +use base 'Test::Class'; +use strict; +use SUPER; +use warnings; + +sub setup_globals { + my $self = shift; + $self->SUPER; + no strict 'refs'; + *{ $self->package_under_test(__PACKAGE__) . '::DB' } = \$self->{mock}; + use strict 'refs'; + +} + +sub test_gen_object : Test(10) { + my $self = shift; + my $instance = Test::MockObject::Extends->new( $self->{instance} ); + my $mock = Test::MockObject->new; + + my ( %gpa, @gpa ); + $mock->fake_module( $self->{class}, + getParamArray => + sub { push @gpa, \@_; return @gpa{qw( q bn f n ou U no i it )} } ); + + my @go; + $mock->fake_module( + 'Everything::HTML::FormObject::TypeMenu', + genObject => sub { push @go, \@_; return 'html' } + ); + + @gpa{qw( q bn f n ou U no i )} = ( + 'query', 'bindNode', 'field', 'name', + 'omitutil', 'USER', 'none', 'inherit' + ); + + my $result = $instance->genObject( 1, 2, 3 ); + is( @gpa, 1, 'genObject() should call getParamArray' ); + is( + $gpa[0][0], + 'query, bindNode, field, name, omitutil, ' + . 'USER, none, inherit, inherittxt', + '... requesting the appropriate arguments' + ); + is_deeply( + [ @{ $gpa[0] }[ 1 .. 3 ] ], + [ 1, 2, 3 ], + '... with the method arguments' + ); + unlike( join( ' ', @{ $gpa[0] } ), + qr/$mock/, '... but not the object itself' ); + is( @go, 1, '... should call SUPER::genObject()' ); + is_deeply( + [ @{ $go[0] } ], + [ + $instance, 'query', 'bindNode', 'field', + 'name', 'nodetype', 'AUTO', 'USER', + 'c', 'none', 'inherit' + ], + '... passing ten correct args' + ); + is( $instance->{omitutil}, 'omitutil', + '... should set $$this{omitutil} to $omitutil' ); + + @gpa{qw(ou U)} = ( undef, undef ); + + $instance->genObject(); + is( $instance->{omitutil}, 0, '... should default $omitutil to 0' ); + is( ${ $go[1] }[7], -1, '... should default $USER to -1' ); + + is( $result, 'html', '... should return result of SUPER::genObject()' ); +} + +sub test_add_types : Test(22) { + my $self = shift; + my $instance = Test::MockObject::Extends->new( $self->{instance} ); + my $mock = $self->{mock}; + + my ( %types, @hTA ); + for ( 'a', 'b', 'c' ) { + $types{$_} = Test::MockObject->new; + $types{$_}->mock( 'hasTypeAccess', sub { push @hTA, $_[0]; 1 } ); + $types{$_}->set_true('derivesFrom'); + $types{$_}->{title} = $_; + } + + $mock->set_list( 'getAllTypes', $types{c}, $types{a}, $types{b} ); + + $instance->set_always( 'createTree', + [ { label => 'l1', value => 'v1' }, { label => 'l2', value => 'v2' } ] + ); + $instance->set_true('addHash'); + $instance->set_true('addArray'); + $instance->set_true('addLabels'); + + my $result = $instance->addTypes( 't', 'U', 'p', 'n', 'i' ); + + my ( $method, $args ) = $instance->next_call; + is( $method, 'addHash', + 'addTypes() should call addHash() if $none defined' ); + is_deeply( + [ @$args[ 1, 2 ] ], + [ { 'None' => 'n' }, 1 ], + '... passing {"None" => $none}, 1' + ); + + ( $method, $args ) = $instance->next_call; + is( $method, 'addHash', '... should call addHash() if $inherit defined' ); + is_deeply( + [ @$args[ 1, 2 ] ], + [ { 'Inherit' => 'i' }, 1 ], + '... passing {"Inherit" => $inherit}, 1' + ); + + ( $method, $args ) = $mock->next_call; + is( $method, 'getAllTypes', '... should call $DB->getAllTypes' ); + + is_deeply( + [@hTA], + [ @types{qw(a b c)} ], + '... should sort returned types by title' + ); + + my $type = Test::MockObject->new; + $type->set_series( 'hasTypeAccess', 1, 1, 1, 0 ); + $type->set_series( 'derivesFrom', 0, 1, 1, 0 ); + $type->{title} = 'title'; + $mock->set_always( 'getAllTypes', $type ); + + $instance->{omitutil} = 1; + $instance->clear; + + $instance->addTypes( 't', 'U', 'p', undef, undef ); + + ( $method, $args ) = $type->next_call; + is( $method, 'hasTypeAccess', '... should check hasTypeAccess() for type' ); + is_deeply( [ @$args[ 1 .. 2 ] ], [ 'U', 'c' ], + '... passing $USER and "c"' ); + + ( $method, $args ) = $type->next_call; + is( $method, 'derivesFrom', + '... should check derivesFrom() if $this->{omitutil}' ); + is( $args->[1], 'utility', '... passing "utility"' ); + + ( $method, $args ) = $instance->next_call; + isnt( $method, 'addHash', + '... should not call addHash() when no $none or $inherit' ); + is( $method, 'createTree', '... should call createTree()' ); + is_deeply( $$args[1], [$type], + '... passing it $TYPE if hasTypeAccess() and not derivesFrom()' ); + + $instance->clear; + + $instance->addTypes( 't', 'U', 'p', undef, undef ); + ( $method, $args ) = $instance->next_call; + is_deeply( [ @{ $$args[1] } ], + [], '... not passing it $TYPE if derivesFrom() and $omitutil' ); + + $instance->{omitutil} = 0; + $instance->clear; + + $instance->addTypes( 't', 'U', 'p', undef, undef ); + + ( $method, $args ) = $instance->next_call; + is_deeply( $$args[1], [$type], + '... passing it $TYPE if hasTypeAccess() and not $omitutil' ); + + $instance->clear; + + $instance->addTypes( 't', 'U', 'p', undef, undef ); + + ( $method, $args ) = $instance->next_call; + is_deeply( [ @{ $$args[1] } ], + [], '... not passing it $TYPE if not hasTypeAccess()' ); + + ( $method, $args ) = $instance->next_call; + is( $method, 'addArray', '... should call addArray()' ); + is_deeply( + $$args[1], + [ 'v1', 'v2' ], + '... passing it ref to array of menu values' + ); + + ( $method, $args ) = $instance->next_call; + is( $method, 'addLabels', '... should call addLabels()' ); + is_deeply( + $$args[1], + { l2 => 'v2', l1 => 'v1' }, + '... passing it ref to hash of all menu label/value pairs' + ); + is( $$args[2], 1, '... and passing it 1' ); + + is( $result, 1, '... should return 1' ); +} + +sub test_create_tree : Test(6) { + + my $self = shift; + my $instance = Test::MockObject::Extends->new( $self->{instance} ); + + no strict 'refs'; + my $create_tree_code = *{ $self->{class} . '::createTree' }{CODE}; + use strict 'refs'; + my $mock = Test::MockObject->new; + $instance->mock( + 'createTree', + sub { + $create_tree_code->(@_); + return [ { label => 'v1' }, { label => 'v2' } ]; + } + ); + + my $types = [ + { extends_nodetype => 0, title => 'zero', node_id => 1 }, + { extends_nodetype => 1, title => 'one1', node_id => 2 }, + { extends_nodetype => 1, title => 'one2', node_id => 3 }, + ]; + + $instance->createTree( $types, 1 ); + + my ( $method, $args ) = $instance->next_call; + ( $method, $args ) = $instance->next_call; + is( $method, 'createTree', 'createTree() should call createTree()' ); + is_deeply( + $args, + [ $instance, $types, 2 ], + '... passing it $types, node_id' + ); + + ( $method, $args ) = $instance->next_call; + is_deeply( + [ $method, @$args ], + [ 'createTree', $instance, $types, 3 ], + '... for each $type with extends_nodetype matching $current' + ); + + ( $method, $args ) = $mock->next_call; + ok( !$method, '... but no more' ); + + my $called = 0; + $instance->clear; + + $instance->set_always( 'createTree', + [ { label => 'v1' }, { label => 'v2' } ] ); + + my $result = $create_tree_code->( $instance, $types, undef ); + + ( $method, $args ) = $instance->next_call; + is( $$args[2], 1, '... $current defaults to 0' ); + + is_deeply( + $result, + [ + { label => ' + zero', value => 1 }, + { label => ' - -v1' }, + { label => ' - -v2' } + ], + '... should return correct nodetype tree' + ); +} + +1; Property changes on: trunk/ebase/lib/Everything/HTML/FormObject/Test/NodetypeMenu.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Added: trunk/ebase/lib/Everything/HTML/FormObject/Test/TypeMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/Test/TypeMenu.pm (rev 0) +++ trunk/ebase/lib/Everything/HTML/FormObject/Test/TypeMenu.pm 2006-09-30 12:48:23 UTC (rev 916) @@ -0,0 +1,127 @@ +package Everything::HTML::FormObject::Test::TypeMenu; + +use base 'Everything::HTML::FormObject::Test::FormMenu'; +use Test::MockObject::Extends; +use Test::More; +use Scalar::Util qw/blessed/; +use base 'Test::Class'; +use strict; +use warnings; + +sub test_add_types : Test(12) { + my $self = shift; + my $instance = Test::MockObject::Extends->new( $self->{instance} ); + my $node = $self->{node}; + $instance->set_true( 'addHash', 'addType' ); + my $result = $instance->addTypes( 't', 'U', 'p', 'n', 'i', 'it' ); + + my ( $method, $args ) = $instance->next_call; + is( $method, 'addHash', + 'addTypes() should call addHash() if defined $none' ); + + ( $method, $args ) = $instance->next_call; + is( $method, 'addHash', + '... should call addHash() again if defined $inherit' ); + is( ${ $args->[1] }{'inherit (it)'}, + 'i', + '... $label should be set to "inherit ($inherittxt)" if $inherittxt' ); + + ( $method, $args ) = $instance->next_call; + is( $method, 'addType', '... should call addType()' ); + is( $args->[2], 'U', '... should use provided $USER' ); + is( $args->[3], 'p', '... and $perm' ); + is( $result, 1, '... should return 1' ); + + $instance->clear; + $instance->addTypes( 't', '', '', 'n' ); + ( $method, $args ) = $instance->next_call; + is( ${ $args->[1] }{None}, + 'n', '... skip an addHash() if $inherit undefined' ); + + ( $method, $args ) = $instance->next_call; + + is( $args->[2], -1, '... $USER defaults to -1' ); + is( $args->[3], 'r', '... and $perm to "r"' ); + + $instance->clear; + $instance->addTypes( 't', 'U', 'p', undef, 'i' ); + ( $method, $args ) = $instance->next_call; + is_deeply( + $args->[1], + { inherit => 'i' }, + '... $label should be set to "inherit" if no $inherittxt' + ); + ( $method, $args ) = $instance->next_call; + is( $method, 'addType', '... skip and addHash() if $none undefined' ); + +} + +sub test_gen_object : Test(16) { + my $self = shift; + my $node = $self->{node}; + my $instance = Test::MockObject::Extends->new( $self->{instance} ); + + $instance->set_true('addTypes'); + $instance->set_always( 'genPopupMenu', "a" ); + my @params; + *Everything::HTML::FormObject::TypeMenu::getParamArray = sub { + push @params, "@_"; + shift; + @_; + }; + + my ( $genObject_name, $genObject_args ); + $node->fake_module( + 'Everything::HTML::FormObject', + genObject => sub { + my $node = shift; + $genObject_name = 'genObject'; + $genObject_args = [@_]; + return 'html'; + } + ); + + my $result = + $instance->genObject( 'q', 'bN', 'f', 'n', 't', 'd', 'U', 'p', 'n', 'i', + 'it' ); + + is( + $params[0], + 'query, bindNode, field, name, type, default, USER, perm, ' + . 'none, inherit, inherittxt q bN f n t d U p n i it', + 'genObject() should call getParamArray() with @_' + ); + is( $genObject_name, 'genObject', '... should call SUPER::genObject()' ); + + my ( $method, $args ) = $instance->next_call; + is( $method, 'addTypes', '... should call addTypes()' ); + is( $args->[1], 't', '... should use provided $type' ); + is( $args->[2], 'U', '... should use provided $USER' ); + is( $args->[3], 'p', '... should use provided $perm' ); + + ( $method, $args ) = $instance->next_call; + is( $method, 'genPopupMenu', '... should call genPopupMenu()' ); + is( $args->[2], 'n', '... should use provided $name' ); + is( $args->[3], undef, '... $default becomes undef if true' ); + is( $result, "html\na", + '... returning concatenation of SUPER() and genPopupMenu() calls' ); + + $instance->clear; + $instance->genObject( 'q', { f => 'field' }, 'f' ); + ( $method, $args ) = $instance->next_call; + is( $args->[1], 'nodetype', '... $type should default to "nodetype"' ); + is( $args->[2], '-1', '... $USER should default to -1' ); + is( $args->[3], 'r', '... $perm should default to "r"' ); + + ( $method, $args ) = $instance->next_call; + is( $args->[2], 'f', '... $name should default to $field' ); + is( $args->[3], 'field', + '... with no default value, should bind to provided node field' ); + $instance->clear; + $instance->genObject( 'q', '', 'field', '', '', 'AUTO' ); + $args = [ $instance->call_args(-1) ]; + is( $args->[3], undef, + '... default value should be undef if "AUTO" and lacking bound node' ); +} + +1; Property changes on: trunk/ebase/lib/Everything/HTML/FormObject/Test/TypeMenu.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Added: trunk/ebase/t/HTML/FormObject/FormMenu.t =================================================================== --- trunk/ebase/t/HTML/FormObject/FormMenu.t (rev 0) +++ trunk/ebase/t/HTML/FormObject/FormMenu.t 2006-09-30 12:48:23 UTC (rev 916) @@ -0,0 +1,5 @@ +#!/usr/bin/perl + +use Everything::HTML::FormObject::Test::FormMenu; + +Everything::HTML::FormObject::Test::FormMenu->runtests; Property changes on: trunk/ebase/t/HTML/FormObject/FormMenu.t ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/t/HTML/FormObject/NodetypeMenu.t =================================================================== --- trunk/ebase/t/HTML/FormObject/NodetypeMenu.t 2006-09-30 09:59:58 UTC (rev 915) +++ trunk/ebase/t/HTML/FormObject/NodetypeMenu.t 2006-09-30 12:48:23 UTC (rev 916) @@ -1,276 +1,4 @@ #!/usr/bin/perl -w -use strict; - -BEGIN -{ - chdir 't' if -d 't'; - unshift @INC, '../blib/lib', 'lib/', '..'; -} - -package Everything::HTML::FormObject::NodetypeMenu; -use vars qw( $DB ); - -package main; - -use vars qw( $AUTOLOAD ); -use Test::More tests => 41; -use Test::MockObject; - -my $package = 'Everything::HTML::FormObject::NodetypeMenu'; - -{ - my @imports; - my @modules = ( 'Everything', 'Everything::HTML::FormObject::TypeMenu' ); - - for (@modules) - { - Test::MockObject->fake_module( $_, - import => sub { push @imports, $_[0] } ); - } - - use_ok($package); - - for ( 0 .. $#modules ) - { - is( $imports[$_], $modules[$_], "Module should use $modules[$_]" ); - } -} - -# genObject() -{ - my $mock = Test::MockObject->new; - - my ( %gpa, @gpa ); - $mock->fake_module( $package, - getParamArray => - sub { push @gpa, \@_; return @gpa{qw( q bn f n ou U no i it )} } ); - - my @go; - $mock->fake_module( - 'Everything::HTML::FormObject::TypeMenu', - genObject => sub { push @go, \@_; return 'html' } - ); - - @gpa{qw( q bn f n ou U no i )} = ( - 'query', 'bindNode', 'field', 'name', - 'omitutil', 'USER', 'none', 'inherit' - ); - - my $result = genObject( $mock, 1, 2, 3 ); - is( @gpa, 1, 'genObject() should call getParamArray' ); - is( - $gpa[0][0], - 'query, bindNode, field, name, omitutil, ' - . 'USER, none, inherit, inherittxt', - '... requesting the appropriate arguments' - ); - is_deeply( - [ @{ $gpa[0] }[ 1 .. 3 ] ], - [ 1, 2, 3 ], - '... with the method arguments' - ); - unlike( join( ' ', @{ $gpa[0] } ), - qr/$mock/, '... but not the object itself' ); - is( @go, 1, '... should call SUPER::genObject()' ); - is_deeply( - [ @{ $go[0] } ], - [ - $mock, 'query', 'bindNode', 'field', - 'name', 'nodetype', 'AUTO', 'USER', - 'c', 'none', 'inherit' - ], - '... passing ten correct args' - ); - is( $mock->{omitutil}, 'omitutil', - '... should set $$this{omitutil} to $omitutil' ); - - @gpa{qw(ou U)} = ( undef, undef ); - - genObject($mock); - is( $mock->{omitutil}, 0, '... should default $omitutil to 0' ); - is( ${ $go[1] }[7], -1, '... should default $USER to -1' ); - - is( $result, 'html', '... should return result of SUPER::genObject()' ); -} - -# addTypes() -{ - my ( %types, @hTA ); - for ( 'a', 'b', 'c' ) - { - $types{$_} = Test::MockObject->new; - $types{$_}->mock( 'hasTypeAccess', sub { push @hTA, $_[0]; 1 } ); - $types{$_}->set_true('derivesFrom'); - $types{$_}->{title} = $_; - } - - my $db = Test::MockObject->new; - $db->set_list( 'getAllTypes', $types{c}, $types{a}, $types{b} ); - $Everything::HTML::FormObject::NodetypeMenu::DB = $db; - - my $mock = Test::MockObject->new; - $mock->set_always( 'createTree', - [ { label => 'l1', value => 'v1' }, { label => 'l2', value => 'v2' } ] - ); - $mock->set_true('addHash'); - $mock->set_true('addArray'); - $mock->set_true('addLabels'); - - my $result = addTypes( $mock, 't', 'U', 'p', 'n', 'i' ); - - my ( $method, $args ) = $mock->next_call; - is( $method, 'addHash', - 'addTypes() should call addHash() if $none defined' ); - is_deeply( - [ @$args[ 1, 2 ] ], - [ { 'None' => 'n' }, 1 ], - '... passing {"None" => $none}, 1' - ); - - ( $method, $args ) = $mock->next_call; - is( $method, 'addHash', '... should call addHash() if $inherit defined' ); - is_deeply( - [ @$args[ 1, 2 ] ], - [ { 'Inherit' => 'i' }, 1 ], - '... passing {"Inherit" => $inherit}, 1' - ); - - ( $method, $args ) = $db->next_call; - is( $method, 'getAllTypes', '... should call $DB->getAllTypes' ); - - is_deeply( - [@hTA], - [ @types{qw(a b c)} ], - '... should sort returned types by title' - ); - - my $type = Test::MockObject->new; - $type->set_series( 'hasTypeAccess', 1, 1, 1, 0 ); - $type->set_series( 'derivesFrom', 0, 1, 1, 0 ); - $type->{title} = 'title'; - $db->set_always( 'getAllTypes', $type ); - - $mock->{omitutil} = 1; - $mock->clear; - - addTypes( $mock, 't', 'U', 'p', undef, undef ); - - ( $method, $args ) = $type->next_call; - is( $method, 'hasTypeAccess', '... should check hasTypeAccess() for type' ); - is_deeply( [ @$args[ 1 .. 2 ] ], [ 'U', 'c' ], - '... passing $USER and "c"' ); - - ( $method, $args ) = $type->next_call; - is( $method, 'derivesFrom', - '... should check derivesFrom() if $this->{omitutil}' ); - is( $args->[1], 'utility', '... passing "utility"' ); - - ( $method, $args ) = $mock->next_call; - isnt( $method, 'addHash', - '... should not call addHash() when no $none or $inherit' ); - is( $method, 'createTree', '... should call createTree()' ); - is_deeply( $$args[1], [$type], - '... passing it $TYPE if hasTypeAccess() and not derivesFrom()' ); - - $mock->clear; - - addTypes( $mock, 't', 'U', 'p', undef, undef ); - ( $method, $args ) = $mock->next_call; - is_deeply( [ @{ $$args[1] } ], - [], '... not passing it $TYPE if derivesFrom() and $omitutil' ); - - $mock->{omitutil} = 0; - $mock->clear; - - addTypes( $mock, 't', 'U', 'p', undef, undef ); - - ( $method, $args ) = $mock->next_call; - is_deeply( $$args[1], [$type], - '... passing it $TYPE if hasTypeAccess() and not $omitutil' ); - - $mock->clear; - - addTypes( $mock, 't', 'U', 'p', undef, undef ); - - ( $method, $args ) = $mock->next_call; - is_deeply( [ @{ $$args[1] } ], - [], '... not passing it $TYPE if not hasTypeAccess()' ); - - ( $method, $args ) = $mock->next_call; - is( $method, 'addArray', '... should call addArray()' ); - is_deeply( - $$args[1], - [ 'v1', 'v2' ], - '... passing it ref to array of menu values' - ); - - ( $method, $args ) = $mock->next_call; - is( $method, 'addLabels', '... should call addLabels()' ); - is_deeply( - $$args[1], - { l2 => 'v2', l1 => 'v1' }, - '... passing it ref to hash of all menu label/value pairs' - ); - is( $$args[2], 1, '... and passing it 1' ); - - is( $result, 1, '... should return 1' ); -} - -# createTree() -{ - my $mock = Test::MockObject->new; - $mock->set_always( 'createTree', [ { label => 'v1' }, { label => 'v2' } ] ); - - my $types = [ - { extends_nodetype => 0, title => 'zero', node_id => 1 }, - { extends_nodetype => 1, title => 'one1', node_id => 2 }, - { extends_nodetype => 1, title => 'one2', node_id => 3 }, - ]; - - createTree( $mock, $types, 1 ); - - my ( $method, $args ) = $mock->next_call; - is( $method, 'createTree', 'createTree() should call createTree()' ); - is_deeply( $args, [ $mock, $types, 2 ], '... passing it $types, node_id' ); - - ( $method, $args ) = $mock->next_call; - is_deeply( - [ $method, @$args ], - [ 'createTree', $mock, $types, 3 ], - '... for each $type with extends_nodetype matching $current' - ); - - ( $method, $args ) = $mock->next_call; - ok( !$method, '... but no more' ); - - $mock->set_always( 'createTree', [ { label => 'v1' }, { label => 'v2' } ] ); - my $result = createTree( $mock, $types, undef ); - - ( $method, $args ) = $mock->next_call; - is( $$args[2], 1, '... $current defaults to 0' ); - - is_deeply( - $result, - [ - { label => ' + zero', value => 1 }, - { label => ' - -v1' }, - { label => ' - -v2' } - ], - '... should return correct nodetype tree' - ); -} - -sub AUTOLOAD -{ - my ($subname) = $AUTOLOAD =~ /([^:]+)$/; - - if ( my $sub = $package->can( $subname ) ) - { - $sub->(@_); - } - else - { - warn "Cannot call <$subname> in ($package)\n"; - } -} +use Everything::HTML::FormObject::Test::NodetypeMenu; +Everything::HTML::FormObject::Test::NodetypeMenu->runtests; Modified: trunk/ebase/t/HTML/FormObject/TypeMenu.t =================================================================== --- trunk/ebase/t/HTML/FormObject/TypeMenu.t 2006-09-30 09:59:58 UTC (rev 915) +++ trunk/ebase/t/HTML/FormObject/TypeMenu.t 2006-09-30 12:48:23 UTC (rev 916) @@ -1,153 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl -use strict; -use vars qw( $AUTOLOAD ); - -BEGIN -{ - chdir 't' if -d 't'; - unshift @INC, '../blib/lib', 'lib/', '..'; -} - -use FakeNode; -use Test::More tests => 32; - -$INC{'Everything.pm'} = $INC{'Everything/HTML/FormObject/FormMenu.pm'} = 1; - -{ - local ( - *Everything::import, - *Everything::HTML::FormObject::FormMenu::import, - *Everything::HTML::FormObject::TypeMenu::import - ); - - my @imports; - *Everything::import = *Everything::HTML::FormObject::FormMenu::import = - sub { - push @imports, $_[0]; - }; - - *Everything::HTML::FormObject::TypeMenu::import = sub { }; - - use_ok('Everything::HTML::FormObject::TypeMenu'); - is( scalar @imports, 2, 'TypeMenu should load two packages' ); - is( $imports[0], 'Everything', '... Everything' ); - is( - $imports[1], - 'Everything::HTML::FormObject::FormMenu', - '... and FormMenu' - ); -} - -# genObject() -{ - local ( - *Everything::HTML::FormObject::TypeMenu::getParamArray, - *Everything::HTML::FormObject::TypeMenu::SUPER::genObject - ); - - my @params; - *Everything::HTML::FormObject::TypeMenu::getParamArray = sub { - push @params, "@_"; - shift; - @_; - }; - - *Everything::HTML::FormObject::TypeMenu::SUPER::genObject = sub { - my $node = shift; - $node->genObject(@_); - return 'html'; - }; - - my $node = FakeNode->new(); - $node->{_subs}{genPopupMenu} = [ 'a', 'b', 'c', 'd' ]; - - my $result = - genObject( $node, 'q', 'bN', 'f', 'n', 't', 'd', 'U', 'p', 'n', 'i', - 'it' ); - - is( - $params[0], - 'query, bindNode, field, name, type, default, USER, perm, ' - . 'none, inherit, inherittxt q bN f n t d U p n i it', - 'genObject() should call getParamArray() with @_' - ); - is( $node->{_calls}[0][0], - 'genObject', '... should call SUPER::genObject()' ); - is( $node->{_calls}[1][0], 'addTypes', '... should call addTypes()' ); - is( $node->{_calls}[2][0], - 'genPopupMenu', '... should call genPopupMenu()' ); - is( $node->{_calls}[2][2], 'n', '... should use provided $name' ); - is( $node->{_calls}[1][1], 't', '... should use provided $type' ); - is( $node->{_calls}[1][2], 'U', '... should use provided $USER' ); - is( $node->{_calls}[1][3], 'p', '... should use provided $perm' ); - is( $node->{_calls}[2][3], undef, '... $default becomes undef if true' ); - is( $result, "html\na", - '... returning concatenation of SUPER() and genPopupMenu() calls' ); - - genObject( $node, 'q', { f => 'field' }, 'f' ); - - is( $node->{_calls}[-2][1], - 'nodetype', '... $type should default to "nodetype"' ); - is( $node->{_calls}[-2][2], '-1', '... $USER should default to -1' ); - is( $node->{_calls}[-2][3], 'r', '... $perm should default to "r"' ); - is( $node->{_calls}[-1][2], 'f', '... $name should default to $field' ); - is( $node->{_calls}[-1][3], - 'field', - '... with no default value, should bind to provided node field' ); - - genObject( $node, 'q', '', 'field', '', '', 'AUTO' ); - is( $node->{_calls}[-1][3], - undef, - '... default value should be undef if "AUTO" and lacking bound node' ); -} - -# addTypes() -{ - my $node = FakeNode->new(); - $node->{_subs} = { - addHash => [ ('H') x 9 ], - addType => [ ('T') x 9 ] - }; - - my $result = addTypes( $node, 't', 'U', 'p', 'n', 'i', 'it' ); - is( $node->{_calls}[0][0], - 'addHash', 'addTypes() should call addHash() if defined $none' ); - is( $node->{_calls}[1][0], - 'addHash', '... should call addHash() again if defined $inherit' ); - is( $node->{_calls}[2][0], 'addType', '... should call addType()' ); - is( $node->{_calls}[2][2], 'U', '... should use provided $USER' ); - is( $node->{_calls}[2][3], 'p', '... and $perm' ); - is( ${ $node->{_calls}[1][1] }{'inherit (it)'}, - 'i', - '... $label should be set to "inherit ($inherittxt)" if $inherittxt' ); - is( $result, 1, '... should return 1' ); - - addTypes( $node, 't', '', '', 'n' ); - is( $node->{_calls}[-1][2], -1, '... $USER defaults to -1' ); - is( $node->{_calls}[-1][3], 'r', '... and $perm to "r"' ); - is( ${ $node->{_calls}[-2][1] }{None}, - 'n', '... skip an addHash() if $inherit undefined' ); - - addTypes( $node, 't', 'U', 'p', undef, 'i' ); - is( $node->{_calls}[-3][0], - 'addType', '... skip and addHash() if $none undefined' ); - is( ${ $node->{_calls}[-2][1] }{inherit}, - 'i', '... $label should be set to "inherit" if no $inherittxt' ); -} - -sub AUTOLOAD -{ - return if $AUTOLOAD =~ /DESTROY$/; - - no strict 'refs'; - $AUTOLOAD =~ s/^main:://; - - my $sub = "Everything::HTML::FormObject::TypeMenu::$AUTOLOAD"; - - if ( defined &{$sub} ) - { - *{$AUTOLOAD} = \&{$sub}; - goto &{$sub}; - } -} +use Everything::HTML::FormObject::Test::TypeMenu; +Everything::HTML::FormObject::Test::TypeMenu->runtests; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-10-01 09:16:21
|
Revision: 918 http://svn.sourceforge.net/everydevel/?rev=918&view=rev Author: paul_the_nomad Date: 2006-10-01 02:16:00 -0700 (Sun, 01 Oct 2006) Log Message: ----------- Datetime tests ported to new unit testing Modified Paths: -------------- trunk/ebase/t/HTML/Datetime.t Added Paths: ----------- trunk/ebase/lib/Everything/HTML/FormObject/Test/Datetime.pm Added: trunk/ebase/lib/Everything/HTML/FormObject/Test/Datetime.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/Test/Datetime.pm (rev 0) +++ trunk/ebase/lib/Everything/HTML/FormObject/Test/Datetime.pm 2006-10-01 09:16:00 UTC (rev 918) @@ -0,0 +1,342 @@ +package Everything::HTML::FormObject::Test::Datetime; + +use Test::More; +use Test::MockObject; +use Test::MockObject::Extends; +use base 'Everything::HTML::Test::FormObject'; +use Scalar::Util qw/blessed/; +use SUPER; +use base 'Test::Class'; +use strict; +use warnings; + +sub setup_globals { + my $self = shift; + $self->SUPER; + no strict 'refs'; + *{ $self->package_under_test(__PACKAGE__) . '::DB' } = \$self->{mock}; + use strict 'refs'; + +} + +sub test_double_digit : Test(3) { + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::doubleDigit' }; + *{ __PACKAGE__ . '::doubleDigit' } = \&{ $self->{class} . '::doubleDigit' }; + use strict 'refs'; + is( ${ [ doubleDigit(2) ] }[0], + '02', 'doubleDigit() should make one-digit numbers two-digit' ); + is( ${ [ doubleDigit(12) ] }[0], + '12', '... should leave two-digit numbers two-digit' ); + is( scalar doubleDigit( 1, 2, 3 ), + 3, '... should process entire lists of numbers' ); +} + +sub test_make_datetime_menu : Test(26) { + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::makeDatetimeMenu' }; + *{ __PACKAGE__ . '::makeDatetimeMenu' } = + \&{ $self->{class} . '::makeDatetimeMenu' }; + use strict 'refs'; + + my $qmock = Test::MockObject->new(); + $qmock->set_always( 'popup_menu', 'pop' ); + + my $result = makeDatetimeMenu( $qmock, 'prefix', '1111-2-3 4:7' ); + my ( $method, $args ) = $qmock->next_call; + shift @$args; + my %hash = @$args; + is( $method, 'popup_menu', 'makeDatetimeMenu() should call popup_menu' ); + is( $hash{-name}, 'prefix_month', '... setting -name to prefixed "month"' ); + is( ${ $hash{ -values } }[0], '01', + '... setting -values to doubled 1 ...' ); + is( ${ $hash{ -values } }[11], + 12, '... through 12 for the possible months' ); + is( scalar keys %{ $hash{-labels} }, + 12, '... passing -labels for each of them' ); + is( $hash{-default}, '02', '... setting -default to the doubled month' ); + + ( $method, $args ) = $qmock->next_call; + shift @$args; + %hash = @$args; + is( $method, 'popup_menu', '... should call popup_menu a second time' ); + is( $hash{-name}, 'prefix_day', '... setting -name to prefixed "day"' ); + is( ${ $hash{ -values } }[0], '01', + '... setting -values to doubled 1 ...' ); + is( ${ $hash{ -values } }[30], 31, + '... through 31 for the possible dates' ); + is( $hash{-default}, '03', '... setting -default to the doubled day' ); + + ( $method, $args ) = $qmock->next_call; + shift @$args; + %hash = @$args; + is( $method, 'popup_menu', '... should call popup_menu a third time' ); + is( $hash{-name}, 'prefix_year', '... setting -name to prefixed "year"' ); + ok( scalar @{ $hash{ -values } } > 1, + '... setting -values to an array of possible years' ); + is( $hash{-default}, 1111, '... setting -default to the year' ); + + ( $method, $args ) = $qmock->next_call; + shift @$args; + %hash = @$args; + is( $method, 'popup_menu', '... should call popup_menu a fourth time' ); + is( $hash{-name}, 'prefix_hour', '... setting -name to prefixed "hour"' ); + is( ${ $hash{ -values } }[0], '00', + '... setting -values to doubled 0 ...' ); + is( ${ $hash{ -values } }[23], 23, + '... through 23 for the possible hours' ); + is( $hash{-default}, '04', '... setting -default to the doubled hour' ); + + ( $method, $args ) = $qmock->next_call; + shift @$args; + %hash = @$args; + is( $method, 'popup_menu', '... should call popup_menu a fifth time' ); + is( $hash{-name}, 'prefix_minute', + '... setting -name to prefixed "minute"' ); + is( ${ $hash{ -values } }[0], '00', + '... setting -values to doubled 0 ...' ); + is( ${ $hash{ -values } }[11], + 55, '... through 55 for the mins. that are multiples of 5' ); + is( $hash{-default}, '05', + '... setting -default to the doubled, rounded-down minute' ); + + is( + $result, + 'poppoppop at poppop', + '... should return concantated popup_menu() calls' + ); +} + +sub test_param_to_datetime : Test(16) { + my $self = shift; + no strict 'refs'; + local *{ __PACKAGE__ . '::paramToDatetime' }; + *{ __PACKAGE__ . '::paramToDatetime' } = + \&{ $self->{class} . '::paramToDatetime' }; + use strict 'refs'; + + my $qmock = Test::MockObject->new; + $qmock->set_series( 'param', 1111, 22, 33, 44, 55 ); + + my $result = paramToDatetime( $qmock, 'prefix' ); + my ( $method, $args ) = $qmock->next_call; + is( $method, 'param', 'paramToDatetime() should call param()' ); + is( + join( ' ', @$args ), + "$qmock prefix_year", + '... passing it one arg (prefixed "year")' + ); + + ( $method, $args ) = $qmock->next_call; + is( $method, 'param', '... should call param() a second time' ); + is( + join( ' ', @$args ), + "$qmock prefix_month", + '... passing it one arg (prefixed "month")' + ); + + ( $method, $args ) = $qmock->next_call; + is( $method, 'param', '... should call param() a third time' ); + is( + join( ' ', @$args ), + "$qmock prefix_day", + '... passing it one arg (prefixed "day")' + ); + + ( $method, $args ) = $qmock->next_call; + is( $method, 'param', '... should call param() a fourth time' ); + is( + join( ' ', @$args ), + "$qmock prefix_hour", + '... passing it one arg (prefixed "hour")' + ); + + ( $method, $args ) = $qmock->next_call; + is( $method, 'param', '... should call param() a fifth time' ); + is( + join( ' ', @$args ), + "$qmock prefix_minute", + '... passing it one arg (prefixed "minute")' + ); + + is( + $result, + '1111-22-33 44:55:00', + '... should return correctly fomatted datetime' + ); + + $qmock->set_series( 'param', 111, 22, 33, 44, 55 ); + $result = paramToDatetime( $qmock, 'prefix' ); + is( + $result, + '0000-00-00 00:00:00', + '... should return "0000-00-00 00:00:00" if bad year format' + ); + + $qmock->set_series( 'param', 1111, 2, 33, 44, 55 ); + $result = paramToDatetime( $qmock, 'prefix' ); + is( $result, '0000-00-00 00:00:00', '... or if bad month format' ); + + $qmock->set_series( 'param', 1111, 22, 3, 44, 55 ); + $result = paramToDatetime( $qmock, 'prefix' ); + is( $result, '0000-00-00 00:00:00', '... or if bad day format' ); + + $qmock->set_series( 'param', 1111, 22, 33, 4, 55 ); + $result = paramToDatetime( $qmock, 'prefix' ); + is( $result, '0000-00-00 00:00:00', '... or if bad hour format' ); + + $qmock->set_series( 'param', 1111, 22, 33, 44, 5 ); + $result = paramToDatetime( $qmock, 'prefix' ); + is( $result, '0000-00-00 00:00:00', '... or if bad minute format' ); +} + +sub test_gen_object : Test(19) { + my $self = shift; + my $instance = Test::MockObject::Extends->new( $self->{instance} ); + my $package = $self->{class}; + my $db = $self->{mock}; + + my ( %gpa, @gpa, @mDM ); + no strict 'refs'; + no warnings 'redefine'; + + ### NB: need to use soft refs here, so 'local' can be used. This + ### is because if mocked in the usual way, the makeDatetimeMenu + ### sub is overriden for all subsequent tests, but it needs to be + ### in its original form + + local *{ $self->{class} . '::getParamArray' } = + sub { push @gpa, \@_; return @gpa{qw( q bn f n d )} }; + + local *{ $self->{class} . '::makeDatetimeMenu' } = + sub { push @mDM, \@_; return 'html2' }; + use strict 'refs'; + use warnings 'redefine'; + + $db->set_always( 'sqlSelect', 'sql' ); + my @go; + $instance->fake_module( 'Everything::HTML::FormObject', + genObject => sub { push @go, \@_; return 'html1' } ); + + $instance->{field} = '1234'; + @gpa{qw( q bn f n d )} = ( 'query', $instance, 'field', 'name', 'def1234' ); + my $result = $instance->genObject( 1, 2, 3 ); + is( @gpa, 1, 'genObject() should call getParamArray' ); + is( + $gpa[0][0], + 'query, bindNode, field, name, default', + '... requesting the appropriate arguments' + ); + like( join( ' ', @{ $gpa[0] } ), + qr/1 2 3$/, '... with the method arguments' ); + unlike( join( ' ', @{ $gpa[0] } ), + qr/$instance/, '... but not the object itself' ); + + is( @go, 1, '... should call SUPER::genObject()' ); + is( + join( ' ', @{ $go[0] } ), + "$instance query $instance field name", + '... passing four args ($query, $bindNode, $field, $name)' + ); + + is( @mDM, 1, '... should call makeDatetimeMenu()' ); + is( @{ $mDM[0] }, 3, '... passing three args' ); + is( ${ $mDM[0] }[0], 'query', '... $query' ); + is( ${ $mDM[0] }[1], 'name', '... $name' ); + is( ${ $mDM[0] }[2], 1234, '... and $date ($bindNode->{$field})' ); + + $instance->{field} = '0000'; + $gpa{n} = ''; + $instance->genObject(); + is( ${ $mDM[1] }[1], + 'field', '... should set $name to $field if not defined' ); + is( ${ $mDM[1] }[2], + 'def1234', '... should set $date to $default if $bindNode bad' ); + + $instance->{field} = ''; + $instance->genObject(); + is( ${ $mDM[2] }[2], + 'def1234', '... and to $default if no $bindNode->{$field}' ); + + $gpa{bn} = 'bindNode'; + $instance->genObject(); + is( ${ $mDM[3] }[2], + 'def1234', '... and to $default if $bindNode is not object' ); + + $gpa{d} = 'def0000'; + $instance->genObject(); + is( ${ $mDM[4] }[2], + 'sql', '... and to the $DB->sqlSelect() call if $default is bad' ); + is( join( ' ', $db->call_args(-1) ), + "$db now()", '... passing "now()" to it' ); + + $gpa{d} = ''; + $instance->genObject(); + is( ${ $mDM[5] }[2], + 'sql', '... and to the $DB->sqlSelect() call if no $default' ); + + is( $result, "html1\nhtml2", + '... should return parent object plus new menu html' ); + +} + +sub test_cgi_update : Test(9) { + + { + my $self = shift; + my $instance = Test::MockObject::Extends->new( $self->{instance} ); + my $package = $self->{class}; + my $db = $self->{mock}; + + my @pTD = (); + + no strict 'refs'; + no warnings 'redefine'; + + ### NB: need to use soft refs here, so 'local' can be used. This + ### is because if mocked in the usual way, the paramToDatetime + ### sub is overriden for all subsequent tests, but it needs to be + ### in its original form + + local *{ $self->{class} . '::paramToDatetime' } = + sub { push @pTD, join ' ', @_ }; + + use strict 'refs'; + use warnings 'redefine'; + + $instance->set_always( 'getBindField', 'field' ); + + my $qmock = Test::MockObject->new(); + my $nmock = Test::MockObject->new(); + $nmock->set_series( 'verifyFieldUpdate', 0, 1, 0 ); + + my @results; + push @results, $instance->cgiUpdate( $qmock, 'name', $nmock, 0 ); + is( scalar @pTD, 1, 'cgiUpdate() should call paramToDatetime' ); + is( $pTD[0], "$qmock name", '... passing two args ($query, $name)' ); + + my ( $method, $args ) = $instance->next_call(); + is( $method, 'getBindField', '... should call getBindField' ); + is( + "@$args", + "$instance $qmock name", + '... passing two args ($query, $name)' + ); + + ( $method, $args ) = $nmock->next_call(); + is( $method, 'verifyFieldUpdate', + '... should check verifyFieldUpdate if not $overrideVerify' ); + is( "@$args", "$nmock field", '... passing it one arg ($field)' ); + + push @results, $instance->cgiUpdate( $qmock, 'name', $nmock, 0 ); + push @results, $instance->cgiUpdate( $qmock, 'name', $nmock, 1 ); + + ok( !$results[0], '... should return false when verify is off' ); + ok( $results[1], '... should return true if $NODE->verifyFieldUpdate' ); + ok( $results[2], '... should return true if $overrideVerify' ); + } + +} +1; Property changes on: trunk/ebase/lib/Everything/HTML/FormObject/Test/Datetime.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/t/HTML/Datetime.t =================================================================== --- trunk/ebase/t/HTML/Datetime.t 2006-09-30 16:50:32 UTC (rev 917) +++ trunk/ebase/t/HTML/Datetime.t 2006-10-01 09:16:00 UTC (rev 918) @@ -1,326 +1,5 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl -use strict; +use Everything::HTML::FormObject::Test::Datetime; +Everything::HTML::FormObject::Test::Datetime->runtests; -BEGIN -{ - chdir 't' if -d 't'; - unshift @INC, '../blib/lib', 'lib/', '..'; -} - -package Everything::HTML::FormObject::Datetime; -use vars qw( $DB ); - -package main; - -use vars qw( $AUTOLOAD ); -use Test::More tests => 76; -use Test::MockObject; - -my $package = 'Everything::HTML::FormObject::Datetime'; - -{ - my @imports; - my @modules = ( 'Everything', 'Everything::HTML::FormObject' ); - - for (@modules) - { - Test::MockObject->fake_module( $_, - import => sub { push @imports, $_[0] } ); - } - - use_ok($package); - - for ( 0 .. $#modules ) - { - is( $imports[$_], $modules[$_], "Module should use $modules[$_]" ); - } -} - -# doubleDigit() -{ - is( ${ [ doubleDigit(2) ] }[0], - '02', 'doubleDigit() should make one-digit numbers two-digit' ); - is( ${ [ doubleDigit(12) ] }[0], - '12', '... should leave two-digit numbers two-digit' ); - is( scalar doubleDigit( 1, 2, 3 ), - 3, '... should process entire lists of numbers' ); -} - -# makeDatetimeMenu() -{ - my $qmock = Test::MockObject->new(); - $qmock->set_always( 'popup_menu', 'pop' ); - - my $result = makeDatetimeMenu( $qmock, 'prefix', '1111-2-3 4:7' ); - my ( $method, $args ) = $qmock->next_call; - shift @$args; - my %hash = @$args; - is( $method, 'popup_menu', 'makeDatetimeMenu() should call popup_menu' ); - is( $hash{-name}, 'prefix_month', '... setting -name to prefixed "month"' ); - is( ${ $hash{ -values } }[0], '01', - '... setting -values to doubled 1 ...' ); - is( ${ $hash{ -values } }[11], - 12, '... through 12 for the possible months' ); - is( scalar keys %{ $hash{-labels} }, - 12, '... passing -labels for each of them' ); - is( $hash{-default}, '02', '... setting -default to the doubled month' ); - - ( $method, $args ) = $qmock->next_call; - shift @$args; - %hash = @$args; - is( $method, 'popup_menu', '... should call popup_menu a second time' ); - is( $hash{-name}, 'prefix_day', '... setting -name to prefixed "day"' ); - is( ${ $hash{ -values } }[0], '01', - '... setting -values to doubled 1 ...' ); - is( ${ $hash{ -values } }[30], 31, - '... through 31 for the possible dates' ); - is( $hash{-default}, '03', '... setting -default to the doubled day' ); - - ( $method, $args ) = $qmock->next_call; - shift @$args; - %hash = @$args; - is( $method, 'popup_menu', '... should call popup_menu a third time' ); - is( $hash{-name}, 'prefix_year', '... setting -name to prefixed "year"' ); - ok( scalar @{ $hash{ -values } } > 1, - '... setting -values to an array of possible years' ); - is( $hash{-default}, 1111, '... setting -default to the year' ); - - ( $method, $args ) = $qmock->next_call; - shift @$args; - %hash = @$args; - is( $method, 'popup_menu', '... should call popup_menu a fourth time' ); - is( $hash{-name}, 'prefix_hour', '... setting -name to prefixed "hour"' ); - is( ${ $hash{ -values } }[0], '00', - '... setting -values to doubled 0 ...' ); - is( ${ $hash{ -values } }[23], 23, - '... through 23 for the possible hours' ); - is( $hash{-default}, '04', '... setting -default to the doubled hour' ); - - ( $method, $args ) = $qmock->next_call; - shift @$args; - %hash = @$args; - is( $method, 'popup_menu', '... should call popup_menu a fifth time' ); - is( $hash{-name}, 'prefix_minute', - '... setting -name to prefixed "minute"' ); - is( ${ $hash{ -values } }[0], '00', - '... setting -values to doubled 0 ...' ); - is( ${ $hash{ -values } }[11], - 55, '... through 55 for the mins. that are multiples of 5' ); - is( $hash{-default}, '05', - '... setting -default to the doubled, rounded-down minute' ); - - is( - $result, - 'poppoppop at poppop', - '... should return concantated popup_menu() calls' - ); -} - -# paramToDatetime() -{ - my $qmock = Test::MockObject->new; - $qmock->set_series( 'param', 1111, 22, 33, 44, 55 ); - - my $result = paramToDatetime( $qmock, 'prefix' ); - my ( $method, $args ) = $qmock->next_call; - is( $method, 'param', 'paramToDatetime() should call param()' ); - is( - join( ' ', @$args ), - "$qmock prefix_year", - '... passing it one arg (prefixed "year")' - ); - - ( $method, $args ) = $qmock->next_call; - is( $method, 'param', '... should call param() a second time' ); - is( - join( ' ', @$args ), - "$qmock prefix_month", - '... passing it one arg (prefixed "month")' - ); - - ( $method, $args ) = $qmock->next_call; - is( $method, 'param', '... should call param() a third time' ); - is( - join( ' ', @$args ), - "$qmock prefix_day", - '... passing it one arg (prefixed "day")' - ); - - ( $method, $args ) = $qmock->next_call; - is( $method, 'param', '... should call param() a fourth time' ); - is( - join( ' ', @$args ), - "$qmock prefix_hour", - '... passing it one arg (prefixed "hour")' - ); - - ( $method, $args ) = $qmock->next_call; - is( $method, 'param', '... should call param() a fifth time' ); - is( - join( ' ', @$args ), - "$qmock prefix_minute", - '... passing it one arg (prefixed "minute")' - ); - - is( - $result, - '1111-22-33 44:55:00', - '... should return correctly fomatted datetime' - ); - - $qmock->set_series( 'param', 111, 22, 33, 44, 55 ); - $result = paramToDatetime( $qmock, 'prefix' ); - is( - $result, - '0000-00-00 00:00:00', - '... should return "0000-00-00 00:00:00" if bad year format' - ); - - $qmock->set_series( 'param', 1111, 2, 33, 44, 55 ); - $result = paramToDatetime( $qmock, 'prefix' ); - is( $result, '0000-00-00 00:00:00', '... or if bad month format' ); - - $qmock->set_series( 'param', 1111, 22, 3, 44, 55 ); - $result = paramToDatetime( $qmock, 'prefix' ); - is( $result, '0000-00-00 00:00:00', '... or if bad day format' ); - - $qmock->set_series( 'param', 1111, 22, 33, 4, 55 ); - $result = paramToDatetime( $qmock, 'prefix' ); - is( $result, '0000-00-00 00:00:00', '... or if bad hour format' ); - - $qmock->set_series( 'param', 1111, 22, 33, 44, 5 ); - $result = paramToDatetime( $qmock, 'prefix' ); - is( $result, '0000-00-00 00:00:00', '... or if bad minute format' ); -} - -# genObject() -{ - my $mock = Test::MockObject->new; - - my ( %gpa, @gpa, @mDM ); - $mock->fake_module( - $package, - getParamArray => sub { push @gpa, \@_; return @gpa{qw( q bn f n d )} }, - makeDatetimeMenu => sub { push @mDM, \@_; return 'html2' } - ); - - my @go; - $mock->fake_module( 'Everything::HTML::FormObject', - genObject => sub { push @go, \@_; return 'html1' } ); - - my $db = Test::MockObject->new; - $db->set_always( 'sqlSelect', 'sql' ); - $Everything::HTML::FormObject::Datetime::DB = $db; - - $mock->{field} = '1234'; - @gpa{qw( q bn f n d )} = ( 'query', $mock, 'field', 'name', 'def1234' ); - my $result = genObject( $mock, 1, 2, 3 ); - is( @gpa, 1, 'genObject() should call getParamArray' ); - is( - $gpa[0][0], - 'query, bindNode, field, name, default', - '... requesting the appropriate arguments' - ); - like( join( ' ', @{ $gpa[0] } ), - qr/1 2 3$/, '... with the method arguments' ); - unlike( join( ' ', @{ $gpa[0] } ), - qr/$mock/, '... but not the object itself' ); - - is( @go, 1, '... should call SUPER::genObject()' ); - is( - join( ' ', @{ $go[0] } ), - "$mock query $mock field name", - '... passing four args ($query, $bindNode, $field, $name)' - ); - - is( @mDM, 1, '... should call makeDatetimeMenu()' ); - is( @{ $mDM[0] }, 3, '... passing three args' ); - is( ${ $mDM[0] }[0], 'query', '... $query' ); - is( ${ $mDM[0] }[1], 'name', '... $name' ); - is( ${ $mDM[0] }[2], 1234, '... and $date ($bindNode->{$field})' ); - - $mock->{field} = '0000'; - $gpa{n} = ''; - genObject($mock); - is( ${ $mDM[1] }[1], - 'field', '... should set $name to $field if not defined' ); - is( ${ $mDM[1] }[2], - 'def1234', '... should set $date to $default if $bindNode bad' ); - - $mock->{field} = ''; - genObject($mock); - is( ${ $mDM[2] }[2], - 'def1234', '... and to $default if no $bindNode->{$field}' ); - - $gpa{bn} = 'bindNode'; - genObject($mock); - is( ${ $mDM[3] }[2], - 'def1234', '... and to $default if $bindNode is not object' ); - - $gpa{d} = 'def0000'; - genObject($mock); - is( ${ $mDM[4] }[2], - 'sql', '... and to the $DB->sqlSelect() call if $default is bad' ); - is( join( ' ', $db->call_args(-1) ), - "$db now()", '... passing "now()" to it' ); - - $gpa{d} = ''; - genObject($mock); - is( ${ $mDM[5] }[2], - 'sql', '... and to the $DB->sqlSelect() call if no $default' ); - - is( $result, "html1\nhtml2", - '... should return parent object plus new menu html' ); -} - -# cgiUpdate() -{ - my $mock = Test::MockObject->new(); - - my @pTD = (); - $mock->fake_module( $package, - paramToDatetime => sub { push @pTD, join ' ', @_ } ); - - $mock->set_always( 'getBindField', 'field' ); - - my $qmock = Test::MockObject->new(); - my $nmock = Test::MockObject->new(); - $nmock->set_series( 'verifyFieldUpdate', 0, 1, 0 ); - - my @results; - push @results, cgiUpdate( $mock, $qmock, 'name', $nmock, 0 ); - is( scalar @pTD, 1, 'cgiUpdate() should call paramToDatetime' ); - is( $pTD[0], "$qmock name", '... passing two args ($query, $name)' ); - - my ( $method, $args ) = $mock->next_call(); - is( $method, 'getBindField', '... should call getBindField' ); - is( "@$args", "$mock $qmock name", '... passing two args ($query, $name)' ); - - ( $method, $args ) = $nmock->next_call(); - is( $method, 'verifyFieldUpdate', - '... should check verifyFieldUpdate if not $overrideVerify' ); - is( "@$args", "$nmock field", '... passing it one arg ($field)' ); - - push @results, cgiUpdate( $mock, $qmock, 'name', $nmock, 0 ); - push @results, cgiUpdate( $mock, $qmock, 'name', $nmock, 1 ); - - ok( !$results[0], '... should return false when verify is off' ); - ok( $results[1], '... should return true if $NODE->verifyFieldUpdate' ); - ok( $results[2], '... should return true if $overrideVerify' ); -} - -sub AUTOLOAD -{ - my ($subname) = $AUTOLOAD =~ /([^:]+)$/; - - if ( my $sub = $package->can( $subname ) ) - { - $sub->(@_); - } - else - { - warn "Cannot call <$subname> in ($package)\n"; - } -} - This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-12-06 09:43:28
|
Revision: 920 http://svn.sourceforge.net/everydevel/?rev=920&view=rev Author: paul_the_nomad Date: 2006-12-06 01:43:27 -0800 (Wed, 06 Dec 2006) Log Message: ----------- Tests for EveryAuth.pm. Also code cleanup. Small amount of documentation for Auth.pm Modified Paths: -------------- trunk/ebase/lib/Everything/Auth/EveryAuth.pm trunk/ebase/lib/Everything/Auth.pm Added Paths: ----------- trunk/ebase/lib/Everything/Auth/Test/ trunk/ebase/lib/Everything/Auth/Test/EveryAuth.pm trunk/ebase/t/Everything/Auth/ trunk/ebase/t/Everything/Auth/EveryAuth.t Modified: trunk/ebase/lib/Everything/Auth/EveryAuth.pm =================================================================== --- trunk/ebase/lib/Everything/Auth/EveryAuth.pm 2006-12-04 10:19:05 UTC (rev 919) +++ trunk/ebase/lib/Everything/Auth/EveryAuth.pm 2006-12-06 09:43:27 UTC (rev 920) @@ -49,7 +49,7 @@ my $passwd = $query->param("passwd"); my $cookie; - my $U = getNode( $user, 'user' ); + my $U = $DB->getNode( $user, 'user' ); $user = $$U{title} if $U; my $USER_HASH; @@ -95,7 +95,7 @@ my $cookie = $query->cookie( -name => 'userpass', -value => "" ); #We need to force the guest user on logouts here, otherwise the cookie won't get cleared. - my $user = getNode( $this->{options}->{guest_user} ); + my $user = $DB->getNode( $this->{options}->{guest_user} ); $$user{cookie} = $cookie if ($cookie); return $user; @@ -117,7 +117,6 @@ sub authUser { my $this = shift; - my ( $user_id, $cookie, $user, $passwd ); my $USER_HASH; if ( my $oldcookie = $query->cookie("userpass") ) @@ -126,13 +125,7 @@ confirmUser( split( /\|/, Everything::Util::unescape($oldcookie) ) ); } - - # Get the user node - $USER_HASH ||= getNode($user_id); - - # Store this user's cookie! - $$USER_HASH{cookie} = $cookie if ( $cookie and $USER_HASH ); - + return unless $USER_HASH; return $USER_HASH; } @@ -156,7 +149,7 @@ sub confirmUser { my ( $nick, $crpasswd ) = @_; - my $user = $DB->getNode( $nick, getType('user') ); + my $user = $DB->getNode( $nick, $DB->getType('user') ); my $genCrypt; return undef unless ($user); Added: trunk/ebase/lib/Everything/Auth/Test/EveryAuth.pm =================================================================== --- trunk/ebase/lib/Everything/Auth/Test/EveryAuth.pm (rev 0) +++ trunk/ebase/lib/Everything/Auth/Test/EveryAuth.pm 2006-12-06 09:43:27 UTC (rev 920) @@ -0,0 +1,185 @@ +package Everything::Auth::Test::EveryAuth; + +use base 'Everything::Test::Abstract'; +use Test::More; +use Test::MockObject; +use SUPER; +use CGI; +use strict; + +sub startup : Test(startup=> 2) { + my $self = shift; + my $module = $self->module_class(); + my $mock = Test::MockObject->new; + $mock->fake_module('Everything'); + $mock->fake_module('Everything::HTML'); + my $cgi = CGI->new; + no strict 'refs'; + *{ $module . '::query' } = \$cgi; + *{ $module . '::DB' } = \$mock; + use strict 'refs'; + use_ok($module) or exit; + $self->{class} = $module; + my $instance = $self->{class}->new; + isa_ok( $instance, $self->{class} ); + $self->{instance} = $instance; + $self->{mock} = $mock; + $self->{cgi} = $cgi; + +} + +sub fixture : Test(setup) { + my $self = shift; + my $class = $self->{class}; + my $cgi = CGI->new; + no strict 'refs'; + *{ $class . '::query' } = \$cgi; + use strict 'refs'; + $self->{cgi} = $cgi; +} + +## +## returns a node of type "user" setting $user->{cookie}. + +sub test_login_user : Test(5) { + my $self = shift; + my $class = $self->{class}; + my $instance = $self->{instance}; + my $cgi = $self->{cgi}; + my $mock = $self->{mock}; + $mock->clear; + can_ok( $class, 'loginUser' ); + + my @args = (); + no strict 'refs'; + local *{ $class . '::confirmUser' }; + *{ $class . '::confirmUser' } = sub { + @args = @_; + return { user => { a => 'user' } }; + }; + use strict 'refs'; + + $mock->set_always( 'getNode', $mock ); + $mock->{title} = "a user title"; + + $cgi->param( 'user', 'username' ); + $cgi->param( 'passwd', 'pw' ); + + my $result = $instance->loginUser; + my ( $method, $args ) = $mock->next_call; + is( $method, 'getNode', '...should get a user node.' ); + is( $args->[1], 'username', '... with args passed by the cgi object.' ); + + ## and calls the confirm user sub + is_deeply( + [@args], + [ 'a user title', crypt( 'pw', 'a user title' ) ], + '...calls confirmUser with correct args' + ); + + my $cookie = $cgi->cookie( + -name => "userpass", + -value => + $cgi->escape( 'a user title' . '|' . crypt( 'pw', 'a user title' ) ), + -expires => $cgi->param("expires") + ); + is( $result->{cookie}, $cookie, + '...and returns a hash containing the cookie.' ); +} + +## returns the node of type 'user' specified by $self-> +sub test_logout_user : Test(4) { + my $self = shift; + my $class = $self->{class}; + my $instance = $self->{instance}; + my $cgi = $self->{cgi}; + my $mock = $self->{mock}; + $mock->clear; + can_ok( $class, 'logoutUser' ); + my $result = $instance->logoutUser; + my ( $method, $args ) = $mock->next_call; + is( $method, 'getNode', '...gets the guest user node' ); + is( + $args->[1], + $instance->{options}->{guest_user}, + '...using the guest user' + ); + my $cookie = $cgi->cookie( + -name => "userpass", + -value => '' + ); + is( $result->{cookie}, $cookie, '...unsetting the cookie value.' ); +} + +## gets cookie and compares it with db using confirmUser. +## returns undef on failure. A node of type user on success. +sub test_auth_user : Test(4) { + + my $self = shift; + my $class = $self->{class}; + my $instance = $self->{instance}; + my $cgi = $self->{cgi}; + my $mock = $self->{mock}; + $mock->set_always( 'getNode', $mock ); + can_ok( $class, 'authUser' ) || return "Can't authUser"; + + ## mock the $query global + my $fake_cgi = Test::MockObject->new; + no strict 'refs'; + local *{ $class . '::query' }; + *{ $class . '::query' } = \$fake_cgi; + use strict 'refs'; + + my $oldcookie = 'a cookie'; + $fake_cgi->set_always( 'cookie', $oldcookie ); + + ## setup confirmUser behaviour + my @a = (); + my @rv = ( { cookie => 'a cookie' }, undef ); + no strict 'refs'; + local *{ $class . '::confirmUser' }; + *{ $class . '::confirmUser' } = sub { + @a = @_; + return shift @rv; + }; + use strict 'refs'; + + my $result = $instance->authUser; + is( "@a", $oldcookie, '...should grab the old cookie.' ); + is( $result->{cookie}, $oldcookie, '...returns the user with the cookie.' ); + + $result = $instance->authUser; + is( $result, undef, '...and returns undef on failure.' ); +} + +## takes two args. The username and a hash of the password +## if no such username or passwords don't match returns undef +## other returns the user node. +sub test_confirm_user : Test(3) { + + my $self = shift; + my $class = $self->{class}; + my $instance = $self->{instance}; + my $cgi = $self->{cgi}; + my $mock = $self->{mock}; + + can_ok( $class, 'confirmUser' ) || return "Can't confirmUser"; + + my $pw = 'password'; + my $name = 'name'; + my $expected_rv = + { title => $name, passwd => $pw, lasttime => 'timestamp' }; + my $crypted = crypt( $pw, $name ); + $mock->set_series( 'getNode', undef, $expected_rv ); + $mock->set_true('getType'); + $mock->set_always( 'sqlSelect', 'timestamp' ); + + my $confirmUser = \&{ $class . '::confirmUser' }; + my $result = $confirmUser->( $name, $crypted ); + is( $result, undef, '..returns undef if getNode doesn\'t get a node.' ); + + $result = $confirmUser->( $name, $crypted ); + is_deeply( $result, $expected_rv, '...returns node if passwords match.' ); +} + +1; Property changes on: trunk/ebase/lib/Everything/Auth/Test/EveryAuth.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/lib/Everything/Auth.pm =================================================================== --- trunk/ebase/lib/Everything/Auth.pm 2006-12-04 10:19:05 UTC (rev 919) +++ trunk/ebase/lib/Everything/Auth.pm 2006-12-06 09:43:27 UTC (rev 920) @@ -31,6 +31,19 @@ Everything::HTML doesn't really need to know that another plugin is there. We should be able to swap them out without changing anything. +It takes one argument, a hash ref. The hash ref takes the following key => value pairs. + +=over + +=item Auth => name of the authorisation module to use. +Defaults to EveryAuth. + +=item guest_user => a node object that is the Guest User to use. + +The authorisation modules may accept other options. Check their document. + +=back + =cut sub new Added: trunk/ebase/t/Everything/Auth/EveryAuth.t =================================================================== --- trunk/ebase/t/Everything/Auth/EveryAuth.t (rev 0) +++ trunk/ebase/t/Everything/Auth/EveryAuth.t 2006-12-06 09:43:27 UTC (rev 920) @@ -0,0 +1,5 @@ +#!/usr/bin/perl + +use Everything::Auth::Test::EveryAuth; + +Everything::Auth::Test::EveryAuth->runtests; \ No newline at end of file Property changes on: trunk/ebase/t/Everything/Auth/EveryAuth.t ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-12-08 13:03:14
|
Revision: 923 http://svn.sourceforge.net/everydevel/?rev=923&view=rev Author: paul_the_nomad Date: 2006-12-08 05:03:10 -0800 (Fri, 08 Dec 2006) Log Message: ----------- Export to request (task 133810). Util.pm export on request only. Also minor changes in modules using Util.pm. Modified Paths: -------------- trunk/ebase/lib/Everything/Node/setting.pm trunk/ebase/lib/Everything/Node.pm trunk/ebase/lib/Everything/Test/Util.pm trunk/ebase/lib/Everything/Util.pm trunk/ebase/t/HTML.t Modified: trunk/ebase/lib/Everything/Node/setting.pm =================================================================== --- trunk/ebase/lib/Everything/Node/setting.pm 2006-12-08 11:50:28 UTC (rev 922) +++ trunk/ebase/lib/Everything/Node/setting.pm 2006-12-08 13:03:10 UTC (rev 923) @@ -14,7 +14,6 @@ use base 'Everything::Node::node'; use Everything::Security; -use Everything::Util; use Everything::XML; use XML::DOM; use Scalar::Util 'reftype'; Modified: trunk/ebase/lib/Everything/Node.pm =================================================================== --- trunk/ebase/lib/Everything/Node.pm 2006-12-08 11:50:28 UTC (rev 922) +++ trunk/ebase/lib/Everything/Node.pm 2006-12-08 13:03:10 UTC (rev 923) @@ -20,7 +20,7 @@ use strict; use Everything (); -use Everything::Util; +use Everything::Util (); use XML::DOM; use SUPER; Modified: trunk/ebase/lib/Everything/Test/Util.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Util.pm 2006-12-08 11:50:28 UTC (rev 922) +++ trunk/ebase/lib/Everything/Test/Util.pm 2006-12-08 13:03:10 UTC (rev 923) @@ -14,7 +14,7 @@ $file .= '.pm'; require $file; - $class->import; + $class->import(qw/escape unescape/); # expressly import these subs } Modified: trunk/ebase/lib/Everything/Util.pm =================================================================== --- trunk/ebase/lib/Everything/Util.pm 2006-12-08 11:50:28 UTC (rev 922) +++ trunk/ebase/lib/Everything/Util.pm 2006-12-08 13:03:10 UTC (rev 923) @@ -13,18 +13,10 @@ use strict; -sub BEGIN -{ - use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - @ISA = qw(Exporter); - @EXPORT = qw( - escape - unescape - ); -} - use URI::Escape (); +use base 'Exporter'; +our (@EXPORT_OK); +@EXPORT_OK = qw/escape unescape/; =cut Modified: trunk/ebase/t/HTML.t =================================================================== --- trunk/ebase/t/HTML.t 2006-12-08 11:50:28 UTC (rev 922) +++ trunk/ebase/t/HTML.t 2006-12-08 13:03:10 UTC (rev 923) @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - use lib 'lib'; + use lib 'lib', '../lib'; } use strict; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-12-10 13:42:16
|
Revision: 926 http://svn.sourceforge.net/everydevel/?rev=926&view=rev Author: paul_the_nomad Date: 2006-12-10 05:42:14 -0800 (Sun, 10 Dec 2006) Log Message: ----------- Task 133810 - Exports from HTML.pm and Everything/Nodeball.pm to export on request only Modified Paths: -------------- trunk/ebase/bin/nbmasta trunk/ebase/lib/Everything/HTML/FormObject/AuthorMenu.pm trunk/ebase/lib/Everything/HTML.pm trunk/ebase/lib/Everything/Nodeball.pm trunk/ebase/web/index.in Modified: trunk/ebase/bin/nbmasta =================================================================== --- trunk/ebase/bin/nbmasta 2006-12-10 10:55:45 UTC (rev 925) +++ trunk/ebase/bin/nbmasta 2006-12-10 13:42:14 UTC (rev 926) @@ -12,7 +12,7 @@ use strict; use Everything; use Everything::Node; -use Everything::Nodeball; +use Everything::Nodeball ':all'; use Everything::XML; my $usagestr =<<END_HERE; Modified: trunk/ebase/lib/Everything/HTML/FormObject/AuthorMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/AuthorMenu.pm 2006-12-10 10:55:45 UTC (rev 925) +++ trunk/ebase/lib/Everything/HTML/FormObject/AuthorMenu.pm 2006-12-10 13:42:14 UTC (rev 926) @@ -11,7 +11,6 @@ use strict; use Everything; -use Everything::HTML; use Everything::HTML::FormObject; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML.pm =================================================================== --- trunk/ebase/lib/Everything/HTML.pm 2006-12-10 10:55:45 UTC (rev 925) +++ trunk/ebase/lib/Everything/HTML.pm 2006-12-10 13:42:14 UTC (rev 926) @@ -17,39 +17,35 @@ use CGI; use CGI::Carp qw(fatalsToBrowser); -sub BEGIN -{ - use Exporter (); - use vars qw($DB $AUTH $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - @ISA = qw(Exporter); - @EXPORT = qw( - $DB - %HTMLVARS - %GLOBAL - $query - $AUTH - newFormObject - parseLinks - htmlScreen - htmlFormatErr - quote - urlGen - getPage - getPageForType - linkNode - linkNodeTitle - searchForNodeByName - evalX - evalXTrapErrors - htmlcode - embedCode - displayPage - gotoNode - encodeHTML - decodeHTML - mod_perlInit); -} +use base 'Exporter'; +our @EXPORT_OK = qw( + $DB + %HTMLVARS + %GLOBAL + $query + $AUTH + newFormObject + parseLinks + htmlScreen + htmlFormatErr + quote + urlGen + getPage + getPageForType + linkNode + linkNodeTitle + searchForNodeByName + evalX + evalXTrapErrors + htmlcode + embedCode + displayPage + gotoNode + encodeHTML + decodeHTML + mod_perlInit); +our ($AUTH, $DB); use vars qw( $query $GNODE $NODELET $THEME $USER $VARS %HTMLVARS %INCJS ); # This is used for nodes to pass vars back-n-forth Modified: trunk/ebase/lib/Everything/Nodeball.pm =================================================================== --- trunk/ebase/lib/Everything/Nodeball.pm 2006-12-10 10:55:45 UTC (rev 925) +++ trunk/ebase/lib/Everything/Nodeball.pm 2006-12-10 13:42:14 UTC (rev 926) @@ -11,14 +11,11 @@ use Everything; use Everything::XML (qw/xmlfile2node fixNodes/); -use vars qw(%OPTIONS); +our %OPTIONS; -sub BEGIN -{ - use Exporter(); - use vars qw($VERSIONS @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - @ISA = qw(Exporter); - @EXPORT = qw( +use base 'Exporter'; + +our @EXPORT_OK = qw( %OPTIONS setupOptions removeNodeball @@ -48,8 +45,9 @@ buildSqlCmdline printSettings ); -} +our %EXPORT_TAGS = ( all => \@EXPORT_OK ); + =cut Modified: trunk/ebase/web/index.in =================================================================== --- trunk/ebase/web/index.in 2006-12-10 10:55:45 UTC (rev 925) +++ trunk/ebase/web/index.in 2006-12-10 13:42:14 UTC (rev 926) @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Everything::HTML; +use Everything::HTML qw/mod_perlInit/; # >>> Extra Packages # <<< Extra Packages This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2006-12-11 09:40:35
|
Revision: 927 http://svn.sourceforge.net/everydevel/?rev=927&view=rev Author: paul_the_nomad Date: 2006-12-11 01:40:32 -0800 (Mon, 11 Dec 2006) Log Message: ----------- Moving globals in Everything to export on request only. Consequent modifications in packages and tests as follows: Everything::CacheQueue Remove use Everything - doesn't actually use Everything.pm lib/Everything/Node/nodeball.pm Remove 'use Everything' - doesn't actually use Everything.pm lib/Everything/Node/user.pm Remove 'use Everything' - doesn't use Everything; lib/Everything/Node/node.pm Added test code lib/Everything/Node/nodegroup.pm 'use Everything' removed. nodegroup.pm does not use anythng from Everything.pm lib/Everything/Nodeball.pm Added explicit ':all'. There are no tests for this module which is used only by nbmasta. No tests for nbmasta either. lib/Everything/Mail.pm Add test code and explicit import lib/Everything/Auth/GuestOnly.pm Removed 'use Everything'. Doesn't use everything lib/Everything/HTML/FormObject.pm lib/Everything/HTML/FormObject/PasswdField.pm lib/Everything/HTML/FormObject/SubsetSelector.pm lib/Everything/HTML/FormObject/TypeMenu.pm lib/Everything/HTML/FormObject/RadioGroup.pm lib/Everything/HTML/FormObject/NodetypeMenu.pm lib/Everything/HTML/FormObject/TextArea.pm lib/Everything/HTML/FormObject/RemoveVarCheckbox.pm lib/Everything/HTML/FormObject/PermissionMenu.pm lib/Everything/HTML/FormObject/VarsTextField.pm lib/Everything/HTML/FormObject/Checkbox.pm lib/Everything/HTML/FormObject/AuthorMenu.pm lib/Everything/HTML/FormObject/TextField.pm lib/Everything/HTML/FormObject/PopupMenu.pm lib/Everything/HTML/FormObject/FormMenu.pm lib/Everything/HTML/FormObject/Datetime.pm lib/Everything/HTML/FormObject/HiddenField.pm lib/Everything/HTML/FormObject/ListMenu.pm lib/Everything/HTML/FormObject/GroupEditor.pm To all the above classes added explicit import of $DB and getParamArray. Also tests added. lib/Everything/XML.pm Added test code and explicit 'getNode' Modified Paths: -------------- trunk/ebase/lib/Everything/Auth/GuestOnly.pm trunk/ebase/lib/Everything/Auth.pm trunk/ebase/lib/Everything/CacheQueue.pm trunk/ebase/lib/Everything/HTML/FormObject/AuthorMenu.pm trunk/ebase/lib/Everything/HTML/FormObject/Checkbox.pm trunk/ebase/lib/Everything/HTML/FormObject/Datetime.pm trunk/ebase/lib/Everything/HTML/FormObject/FormMenu.pm trunk/ebase/lib/Everything/HTML/FormObject/GroupEditor.pm trunk/ebase/lib/Everything/HTML/FormObject/HiddenField.pm trunk/ebase/lib/Everything/HTML/FormObject/ListMenu.pm trunk/ebase/lib/Everything/HTML/FormObject/NodetypeMenu.pm trunk/ebase/lib/Everything/HTML/FormObject/PasswdField.pm trunk/ebase/lib/Everything/HTML/FormObject/PermissionMenu.pm trunk/ebase/lib/Everything/HTML/FormObject/PopupMenu.pm trunk/ebase/lib/Everything/HTML/FormObject/RadioGroup.pm trunk/ebase/lib/Everything/HTML/FormObject/RemoveVarCheckbox.pm trunk/ebase/lib/Everything/HTML/FormObject/SubsetSelector.pm trunk/ebase/lib/Everything/HTML/FormObject/TextArea.pm trunk/ebase/lib/Everything/HTML/FormObject/TextField.pm trunk/ebase/lib/Everything/HTML/FormObject/TypeMenu.pm trunk/ebase/lib/Everything/HTML/FormObject/VarsTextField.pm trunk/ebase/lib/Everything/HTML/FormObject.pm trunk/ebase/lib/Everything/HTML/Test/FormObject.pm trunk/ebase/lib/Everything/HTML.pm trunk/ebase/lib/Everything/Mail.pm trunk/ebase/lib/Everything/Node/Test/extendednode.pm trunk/ebase/lib/Everything/Node/Test/node.pm trunk/ebase/lib/Everything/Node/Test/nodeball.pm trunk/ebase/lib/Everything/Node/Test/nodegroup.pm trunk/ebase/lib/Everything/Node/Test/setting.pm trunk/ebase/lib/Everything/Node/node.pm trunk/ebase/lib/Everything/Node/nodeball.pm trunk/ebase/lib/Everything/Node/nodegroup.pm trunk/ebase/lib/Everything/Node/user.pm trunk/ebase/lib/Everything/Nodeball.pm trunk/ebase/lib/Everything/Test/Auth.pm trunk/ebase/lib/Everything/Test/CacheQueue.pm trunk/ebase/lib/Everything/Test/Mail.pm trunk/ebase/lib/Everything/Test/XML.pm trunk/ebase/lib/Everything/XML.pm trunk/ebase/lib/Everything.pm trunk/ebase/t/HTML.t Modified: trunk/ebase/lib/Everything/Auth/GuestOnly.pm =================================================================== --- trunk/ebase/lib/Everything/Auth/GuestOnly.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Auth/GuestOnly.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,6 @@ ############################################################################# use strict; -use Everything; sub new { Modified: trunk/ebase/lib/Everything/Auth.pm =================================================================== --- trunk/ebase/lib/Everything/Auth.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Auth.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -19,7 +19,7 @@ package Everything::Auth; use strict; -use Everything; +use Everything qw/$DB/; =cut Modified: trunk/ebase/lib/Everything/CacheQueue.pm =================================================================== --- trunk/ebase/lib/Everything/CacheQueue.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/CacheQueue.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -14,7 +14,6 @@ package Everything::CacheQueue; use strict; -use Everything; =cut Modified: trunk/ebase/lib/Everything/HTML/FormObject/AuthorMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/AuthorMenu.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/AuthorMenu.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::AuthorMenu; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/Checkbox.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/Checkbox.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/Checkbox.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::Checkbox; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/Datetime.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/Datetime.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/Datetime.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::Datetime; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/FormMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/FormMenu.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/FormMenu.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -22,7 +22,7 @@ package Everything::HTML::FormObject::FormMenu; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/GroupEditor.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/GroupEditor.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/GroupEditor.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::GroupEditor; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::FormMenu; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/HiddenField.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/HiddenField.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/HiddenField.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::HiddenField; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/ListMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/ListMenu.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/ListMenu.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::ListMenu; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::FormMenu; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/NodetypeMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/NodetypeMenu.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/NodetypeMenu.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::NodetypeMenu; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::TypeMenu; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/PasswdField.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/PasswdField.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/PasswdField.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,8 +10,8 @@ package Everything::HTML::FormObject::PasswdField; use strict; -use Everything; +use Everything qw/getParamArray/; use Everything::HTML::FormObject; use vars qw(@ISA); @ISA = ("Everything::HTML::FormObject"); Modified: trunk/ebase/lib/Everything/HTML/FormObject/PermissionMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/PermissionMenu.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/PermissionMenu.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::PermissionMenu; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::FormMenu; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/PopupMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/PopupMenu.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/PopupMenu.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::PopupMenu; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::FormMenu; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/RadioGroup.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/RadioGroup.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/RadioGroup.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::RadioGroup; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::FormMenu; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/RemoveVarCheckbox.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/RemoveVarCheckbox.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/RemoveVarCheckbox.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::RemoveVarCheckbox; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::Checkbox; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/SubsetSelector.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/SubsetSelector.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/SubsetSelector.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::SubsetSelector; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::FormMenu; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/TextArea.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/TextArea.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/TextArea.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::TextArea; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/TextField.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/TextField.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/TextField.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::TextField; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/TypeMenu.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/TypeMenu.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/TypeMenu.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::TypeMenu; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::FormMenu; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject/VarsTextField.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject/VarsTextField.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject/VarsTextField.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject::VarsTextField; use strict; -use Everything; +use Everything qw/$DB getParamArray/; use Everything::HTML::FormObject::FormMenu; use vars qw(@ISA); Modified: trunk/ebase/lib/Everything/HTML/FormObject.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/FormObject.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/FormObject.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::HTML::FormObject; use strict; -use Everything; +use Everything qw/$DB getParamArray/; =cut Modified: trunk/ebase/lib/Everything/HTML/Test/FormObject.pm =================================================================== --- trunk/ebase/lib/Everything/HTML/Test/FormObject.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML/Test/FormObject.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -11,27 +11,59 @@ use strict; use warnings; -sub startup : Test(startup => +0) { +sub startup : Test(startup => 1) { my $self = shift; # Unfortunately this imports stuff from Everything.pm. my $mock = Test::MockObject->new; $self->{mock} = $mock; - $self->setup_globals; - $self->setup_mocks; my $module = $self->module_class(); - use_ok($module) or exit; $self->{class} = $module; + $self->setup_mocks; + $self->setup_globals; + + use_ok($module); +} +sub test_imports :Test(startup => 1) { + + my $self = shift; + is_deeply( + $self->{import}->{Everything}, + { '$DB' => 1, 'getParamArray' => 1}, + '...imports $DB and getParamArray from Everything' + ); + } sub setup_mocks { my $self = shift; - $self->{mock}->fake_module('Everything'); + my $mock = Test::MockObject->new; + # test imports + my %import; + my $mockimport = sub { + + # this little stanza is required to test the imports of + # sublasses to FormObject.pm. Otherwise we keep rechecking the + # imports only of FormObject + my $caller = caller(); + $caller =~ s{/}{::}g; + $caller =~ s{\.pm$}{}; + return unless $caller eq $self->{class}; + + $import{ +shift } = { map { $_ => 1 } @_[ 1 .. $#_ ] }; + + }; + + for my $mod ( 'Everything' ) { + $mock->fake_module( $mod, import => $mockimport ); + } + $self->{import} = \%import; } + sub setup_globals { my $self = shift; no strict 'refs'; Modified: trunk/ebase/lib/Everything/HTML.pm =================================================================== --- trunk/ebase/lib/Everything/HTML.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/HTML.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -11,7 +11,7 @@ package Everything::HTML; use strict; -use Everything; +use Everything ':all'; use Everything::Mail qw/node2mail mail2node/; use Everything::Auth; use CGI; Modified: trunk/ebase/lib/Everything/Mail.pm =================================================================== --- trunk/ebase/lib/Everything/Mail.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Mail.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -6,7 +6,7 @@ package Everything::Mail; use strict; -use Everything; +use Everything qw/getNode/; use IO::File; use Mail::Sender; use Mail::Address; Modified: trunk/ebase/lib/Everything/Node/Test/extendednode.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/extendednode.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Node/Test/extendednode.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -36,6 +36,10 @@ } +sub test_imports :Test(startup => 0) { + return "Doesn't import symbols"; +} + sub make_fixture :Test(setup => 6) { my $self = shift; Modified: trunk/ebase/lib/Everything/Node/Test/node.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/node.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Node/Test/node.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -18,46 +18,69 @@ use Everything::NodeBase; use Everything::DB::sqlite; -sub node_class -{ - my $self = shift; - my $name = blessed( $self ); - $name =~ s/Test:://; - return $name; +sub node_class { + my $self = shift; + my $name = blessed($self); + $name =~ s/Test:://; + return $name; } -sub startup :Test( startup => 3 ) -{ - my $self = shift; - $self->{errors} = []; +sub startup : Test( startup => 3 ) { + my $self = shift; + $self->{errors} = []; - $self->make_base_test_db(); + $self->make_base_test_db(); - my $mock = Test::MockObject->new(); - $mock->fake_module( 'Everything', logErrors => sub - { - push @{ $self->{errors} }, [@_] - } - ); - *Everything::Node::node::DB = \$mock; + my $mock = Test::MockObject->new(); + $mock->fake_module( + 'Everything', + logErrors => sub { + push @{ $self->{errors} }, [@_]; + } + ); + *Everything::Node::node::DB = \$mock; - my $module = $self->node_class(); - my %import; + my $module = $self->node_class(); + my %import; - my $mockimport = sub { $import{ +shift }++ }; + my $mockimport = sub { + $import{ +shift } = { map { $_ => 1 } @_[ 1 .. $#_ ] }; + }; - for my $mod (qw( DBI Everything Everything::XML)) - { - $mock->fake_module( $mod, import => $mockimport ); - } + for my $mod ( $self->setup_imports ) { + $mock->fake_module( $mod, import => $mockimport ); + } - use_ok( $module ) or exit; + use_ok($module) or exit; - # now test that C<new()> works - can_ok( $module, 'new' ); - isa_ok( $module->new(), $module ); + $self->{imports} = \%import; + + # now test that C<new()> works + can_ok( $module, 'new' ); + isa_ok( $module->new(), $module ); } +sub setup_imports { + + return qw( DBI Everything Everything::XML); +} + +sub test_imports :Test(startup => 2) { + my ( $self) = @_; + my $imports = $self->{imports}; + is_deeply( + $$imports{Everything}, + { '$DB' => 1}, + '...imports $DB from Everything' + ); + is_deeply( + $$imports{'Everything::XML'}, + { xml2node => 1, genBasicTag => 1, parseBasicTag => 1 }, + '...imports xml2node, genBasicTag, parseBasicTag from Everything::XML' + ); + +} + sub make_base_test_db { my $self = shift; Modified: trunk/ebase/lib/Everything/Node/Test/nodeball.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/nodeball.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Node/Test/nodeball.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -7,6 +7,16 @@ use Test::More; + +sub setup_imports { + + return (); +} + +sub test_imports :Test(startup => 0) { + return "Doesn't import symbols"; +} + sub test_dbtables :Test( 2 ) { my $self = shift; Modified: trunk/ebase/lib/Everything/Node/Test/nodegroup.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/nodegroup.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Node/Test/nodegroup.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -7,6 +7,25 @@ use Test::More; + +sub setup_imports { + + return qw( Everything::XML); +} + +sub test_imports :Test(startup => 1) { + my ( $self) = @_; + my $imports = $self->{imports}; + + is_deeply( + $$imports{'Everything::XML'}, + { genBasicTag => 1 }, + '...imports genBasicTag from Everything::XML' + ); + +} + + sub test_construct :Test( 1 ) { my $self = shift; Modified: trunk/ebase/lib/Everything/Node/Test/setting.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/setting.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Node/Test/setting.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -7,6 +7,23 @@ use Test::More; + +sub setup_imports { + + return ('Everything::XML'); +} + +sub test_imports :Test(startup => 1) { + my ( $self) = @_; + my $imports = $self->{imports}; + is_deeply( + $$imports{'Everything::XML'}, + { genBasicTag => 1, parseBasicTag => 1}, + '...imports genBasicTag and parseBasicTag from Everything::XML' + ); +} + + sub test_extends :Test( +1 ) { my $self = shift; Modified: trunk/ebase/lib/Everything/Node/node.pm =================================================================== --- trunk/ebase/lib/Everything/Node/node.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Node/node.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -14,8 +14,8 @@ use base 'Everything::Node'; use DBI; -use Everything; -use Everything::XML (qw/xml2node genBasicTag parseBasicTag/); +use Everything qw/$DB/; +use Everything::XML qw/xml2node genBasicTag parseBasicTag/; use Everything::NodeBase; use Scalar::Util 'reftype'; Modified: trunk/ebase/lib/Everything/Node/nodeball.pm =================================================================== --- trunk/ebase/lib/Everything/Node/nodeball.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Node/nodeball.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -13,7 +13,6 @@ use base 'Everything::Node::nodegroup'; -use Everything; use Everything::Node::setting; =head2 C<dbtables()> Modified: trunk/ebase/lib/Everything/Node/nodegroup.pm =================================================================== --- trunk/ebase/lib/Everything/Node/nodegroup.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Node/nodegroup.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -13,7 +13,6 @@ use base 'Everything::Node::node'; -use Everything; use Everything::XML (qw/genBasicTag/); use XML::DOM; Modified: trunk/ebase/lib/Everything/Node/user.pm =================================================================== --- trunk/ebase/lib/Everything/Node/user.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Node/user.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -11,7 +11,6 @@ use strict; use warnings; -use Everything; use base 'Everything::Node::setting'; =head2 C<dbtables()> Modified: trunk/ebase/lib/Everything/Nodeball.pm =================================================================== --- trunk/ebase/lib/Everything/Nodeball.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Nodeball.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -8,8 +8,8 @@ package Everything::Nodeball; use strict; -use Everything; -use Everything::XML (qw/xmlfile2node fixNodes/); +use Everything qw/:all/; +use Everything::XML qw/xmlfile2node fixNodes/; our %OPTIONS; Modified: trunk/ebase/lib/Everything/Test/Auth.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Auth.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Test/Auth.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -9,14 +9,26 @@ use SUPER; use strict; -sub startup : Test( startup => +5 ) { +sub startup : Test( startup => +6 ) { my $self = shift; - $self->SUPER; - can_ok( $self->{class}, 'new' ); my $db = Test::MockObject->new(); local *Everything::Auth::DB; + my @imports; *Everything::Auth::DB = \$db; + + $db->fake_module( + 'Everything', + import => sub { + @imports = @_; + *Everything::Auth::DB = \$db; + } + ); + + $self->SUPER; + is( $imports[1], '$DB', '...should import $DB from Everything.pm' ); + can_ok( $self->{class}, 'new' ); + $db->set_always( getNode => { node_id => 88 } ); $self->{db} = $db; my $instance = $self->{class}->new(); Modified: trunk/ebase/lib/Everything/Test/CacheQueue.pm =================================================================== --- trunk/ebase/lib/Everything/Test/CacheQueue.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Test/CacheQueue.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -6,12 +6,11 @@ use strict; use warnings; -sub startup : Test(startup => +1) { +sub startup : Test(startup => +0) { my $self = shift; my $mock = Test::MockObject->new; my $import; - $mock->fake_module( 'Everything', import => sub { $import = caller } ); $self->SUPER; my $class = $self->{class}; @@ -23,9 +22,6 @@ require $file; $class->import; - is( $import, 'Everything::CacheQueue', - 'Everything::CacheQueue should use() Everything' ); - } sub setup : Test(setup) { Modified: trunk/ebase/lib/Everything/Test/Mail.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Mail.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Test/Mail.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ use strict; use warnings; -sub startup : Test(startup => +0) { +sub startup : Test(startup => +1) { my $self = shift; # We'll need a few MockObjects here @@ -78,6 +78,17 @@ } ); + # test imports + my %import; + + my $mockimport = sub { + $import{ +shift } = { map { $_ => 1 } @_[ 1 .. $#_ ] }; + }; + + for my $mod ('Everything') { + $mock->fake_module( $mod, import => $mockimport ); + } + # We want to test whether or not someone closes this object # like they should. This just trips a flag for it. @@ -93,6 +104,11 @@ $self->{SETTINGS} = $SETTINGS; $self->SUPER; + is_deeply( + $import{Everything}, + { 'getNode' => 1 }, + '...imports getNode from Everything' + ); } sub test_node2mail : Test(29) { Modified: trunk/ebase/lib/Everything/Test/XML.pm =================================================================== --- trunk/ebase/lib/Everything/Test/XML.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/Test/XML.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -7,7 +7,7 @@ use base 'Everything::Test::Abstract'; -sub startup : Test(startup => +0) { +sub startup : Test(startup => +1) { my $self = shift; my $mock = Test::MockObject->new; @@ -16,9 +16,25 @@ logErrors => sub { push @{ $self->{le} }, [@_] } ); $mock->fake_module('XML::DOM'); + # test imports + my %import; + + my $mockimport = sub { + $import{ +shift } = { map { $_ => 1 } @_[ 1 .. $#_ ] }; + }; + + for my $mod ( 'Everything' ) { + $mock->fake_module( $mod, import => $mockimport ); + } $self->SUPER; + $self->{mock} = $mock; + is_deeply( + $import{Everything}, + { 'getNode' => 1}, + '...imports getNode from Everything' + ); } sub test_readtag : Test(1) { Modified: trunk/ebase/lib/Everything/XML.pm =================================================================== --- trunk/ebase/lib/Everything/XML.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything/XML.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -10,7 +10,7 @@ package Everything::XML; use strict; -use Everything; +use Everything qw/getNode/; use XML::DOM; Modified: trunk/ebase/lib/Everything.pm =================================================================== --- trunk/ebase/lib/Everything.pm 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/lib/Everything.pm 2006-12-11 09:40:32 UTC (rev 927) @@ -36,12 +36,9 @@ # Are we being run from the command line? use vars qw($commandLine); -sub BEGIN -{ - use Exporter (); - use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - @ISA = qw(Exporter); - @EXPORT = qw( +use base 'Exporter'; + +our @EXPORT_OK = qw( $DB getParamArray getRef @@ -74,10 +71,11 @@ @bsErrors ); +our %EXPORT_TAGS = ( all => \@EXPORT_OK ); + # This will be true if we are being run from a command line, in which # case all errors should be printed to STDOUT $commandLine = ( -t STDIN && -t STDOUT ) ? 1 : 0; -} ############################################################################# # Modified: trunk/ebase/t/HTML.t =================================================================== --- trunk/ebase/t/HTML.t 2006-12-10 13:42:14 UTC (rev 926) +++ trunk/ebase/t/HTML.t 2006-12-11 09:40:32 UTC (rev 927) @@ -16,6 +16,7 @@ use File::Path; use Test::More tests => 96; use Test::MockObject; +require Everything; # temporarily avoid sub redefined warnings my $mock = Test::MockObject->new(); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2007-01-03 19:47:08
|
Revision: 932 http://svn.sourceforge.net/everydevel/?rev=932&view=rev Author: paul_the_nomad Date: 2007-01-03 11:47:06 -0800 (Wed, 03 Jan 2007) Log Message: ----------- Remove some imports from Everything::XML Modified Paths: -------------- trunk/ebase/lib/Everything/Node/Test/node.pm trunk/ebase/lib/Everything/Node/Test/setting.pm trunk/ebase/lib/Everything/Node/node.pm trunk/ebase/lib/Everything/Node/setting.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 + 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:935 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/lib/Everything/Node/Test/node.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/node.pm 2006-12-28 20:30:01 UTC (rev 931) +++ trunk/ebase/lib/Everything/Node/Test/node.pm 2007-01-03 19:47:06 UTC (rev 932) @@ -75,7 +75,7 @@ ); is_deeply( $$imports{'Everything::XML'}, - { xml2node => 1, genBasicTag => 1, parseBasicTag => 1 }, + { genBasicTag => 1 }, '...imports xml2node, genBasicTag, parseBasicTag from Everything::XML' ); Modified: trunk/ebase/lib/Everything/Node/Test/setting.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/setting.pm 2006-12-28 20:30:01 UTC (rev 931) +++ trunk/ebase/lib/Everything/Node/Test/setting.pm 2007-01-03 19:47:06 UTC (rev 932) @@ -18,7 +18,7 @@ my $imports = $self->{imports}; is_deeply( $$imports{'Everything::XML'}, - { genBasicTag => 1, parseBasicTag => 1}, + { genBasicTag => 1 }, '...imports genBasicTag and parseBasicTag from Everything::XML' ); } Modified: trunk/ebase/lib/Everything/Node/node.pm =================================================================== --- trunk/ebase/lib/Everything/Node/node.pm 2006-12-28 20:30:01 UTC (rev 931) +++ trunk/ebase/lib/Everything/Node/node.pm 2007-01-03 19:47:06 UTC (rev 932) @@ -15,7 +15,7 @@ use DBI; use Everything qw/$DB/; -use Everything::XML qw/xml2node genBasicTag parseBasicTag/; +use Everything::XML qw/genBasicTag/; use Everything::NodeBase; use Scalar::Util 'reftype'; Modified: trunk/ebase/lib/Everything/Node/setting.pm =================================================================== --- trunk/ebase/lib/Everything/Node/setting.pm 2006-12-28 20:30:01 UTC (rev 931) +++ trunk/ebase/lib/Everything/Node/setting.pm 2007-01-03 19:47:06 UTC (rev 932) @@ -14,7 +14,7 @@ use base 'Everything::Node::node'; use Everything::Security; -use Everything::XML (qw/genBasicTag parseBasicTag/); +use Everything::XML (qw/genBasicTag/); use XML::DOM; use Scalar::Util 'reftype'; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2007-01-03 19:48:00
|
Revision: 933 http://svn.sourceforge.net/everydevel/?rev=933&view=rev Author: paul_the_nomad Date: 2007-01-03 11:47:50 -0800 (Wed, 03 Jan 2007) Log Message: ----------- Remove node to XML code from Node/node.pm and subclasses to Everything/XML/Node.pm. Remove all imports from XML.pm to Node/node.pm and subclasses. Node.pm remains. Modified Paths: -------------- trunk/ebase/lib/Everything/Node/Test/node.pm trunk/ebase/lib/Everything/Node/Test/nodeball.pm trunk/ebase/lib/Everything/Node/Test/nodegroup.pm trunk/ebase/lib/Everything/Node/Test/setting.pm trunk/ebase/lib/Everything/Node/node.pm trunk/ebase/lib/Everything/Node/nodeball.pm trunk/ebase/lib/Everything/Node/nodegroup.pm trunk/ebase/lib/Everything/Node/setting.pm trunk/ebase/lib/Everything/Test/XML.pm trunk/ebase/lib/Everything/XML.pm Added Paths: ----------- trunk/ebase/lib/Everything/XML/ trunk/ebase/lib/Everything/XML/Node.pm trunk/ebase/lib/Everything/XML/Test/ trunk/ebase/lib/Everything/XML/Test/Node.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:935 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 + 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:936 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/lib/Everything/Node/Test/node.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/node.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/Node/Test/node.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -62,10 +62,10 @@ sub setup_imports { - return qw( DBI Everything Everything::XML); + return qw( DBI Everything ); } -sub test_imports :Test(startup => 2) { +sub test_imports :Test(startup => 1) { my ( $self) = @_; my $imports = $self->{imports}; is_deeply( @@ -73,11 +73,6 @@ { '$DB' => 1}, '...imports $DB from Everything' ); - is_deeply( - $$imports{'Everything::XML'}, - { genBasicTag => 1 }, - '...imports xml2node, genBasicTag, parseBasicTag from Everything::XML' - ); } @@ -448,31 +443,6 @@ '... and removing non-export keys as well' ); } -sub test_field_to_XML :Test( 5 ) -{ - my $self = shift; - my $node = $self->{node}; - my @gbt; - - local *Everything::Node::node::genBasicTag; - - *Everything::Node::node::genBasicTag = sub { - push @gbt, [@_]; - return 'tag'; - }; - - $node->{afield} = 'thisfield'; - is( $node->fieldToXML( $node, 'afield' ), 'tag', - 'fieldToXML() should return an XML tag element' ); - is( @gbt, 1, '... and should call genBasicTag()' ); - is( join( ' ', @{ $gbt[0] } ), "$node field afield thisfield", - '... with the correct arguments' ); - - ok( ! $node->fieldToXML( $node, 'notafield' ), - '... and should return false if field does not exist' ); - ok( ! exists $node->{notafield}, '... and should not create field' ); -} - sub test_get_identifying_fields :Test( 1 ) { my $self = shift; Modified: trunk/ebase/lib/Everything/Node/Test/nodeball.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/nodeball.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/Node/Test/nodeball.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -114,28 +114,4 @@ ok( $node->hasVars(), 'hasVars() should return true' ); } -sub test_field_to_XML :Test( 4 ) -{ - my $self = shift; - my $node = $self->{node}; - - my @saveargs; - local *Everything::Node::setting::fieldToXML; - *Everything::Node::setting::fieldToXML = sub { @saveargs = @_ }; - - my @args = ( 'doc', '', 1 ); - $node->set_always( SUPER => 4 ); - - is( $node->fieldToXML(@args), 4, - 'fieldToXML() should call SUPER() unless handling a "vars" field' ); - - my ($method, $args) = $node->next_call(); - is_deeply( $args, [ $node, @args ], '... passing all arguments' ); - - $args[1] = 'vars'; - is( $node->fieldToXML( @args ), 4, - '... delegating to setting nodetype if handling "vars" field' ); - is( "@saveargs", "$node @args", '... passing along its arguments' ); -} - 1; Modified: trunk/ebase/lib/Everything/Node/Test/nodegroup.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/nodegroup.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/Node/Test/nodegroup.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -7,25 +7,6 @@ use Test::More; - -sub setup_imports { - - return qw( Everything::XML); -} - -sub test_imports :Test(startup => 1) { - my ( $self) = @_; - my $imports = $self->{imports}; - - is_deeply( - $$imports{'Everything::XML'}, - { genBasicTag => 1 }, - '...imports genBasicTag from Everything::XML' - ); - -} - - sub test_construct :Test( 1 ) { my $self = shift; @@ -483,64 +464,6 @@ ok( !exists $node->getNodeKeys()->{group}, '... excluding it otherwise' ); } -sub test_field_to_XML :Test( +8 ) -{ - my $self = shift; - my $node = $self->{node}; - $self->SUPER(); - - $node->set_series( SUPER => ( 5, 6, 7 ) ) - ->set_true('appendChild'); - - my $result = $node->fieldToXML( 'doc', 'field', 0 ); - my ($method, $args) = $node->next_call(); - - is( $method, 'SUPER', - 'fieldToXML() should call SUPER() unless handling a group field' ); - is( join( '-', @$args ), "$node-doc-field-0", '... passing args' ); - - is( $result, 5, '... returning the results' ); - { - local ( *XML::DOM::Element::new, *XML::DOM::Text::new, - *Everything::Node::nodegroup::genBasicTag ); - - my @xd; - *XML::DOM::Text::new = sub { - push @xd, [@_]; - return @_; - }; - *XML::DOM::Element::new = sub { - push @xd, [@_]; - return $node; - }; - - my @gbt; - *Everything::Node::nodegroup::genBasicTag = sub { - push @gbt, [@_]; - }; - - $node->{group} = [ 3, 4, 5 ]; - $result = $node->fieldToXML( 'doc', 'group', "\r" ); - - is( join( ' ', @{ $xd[0] } ), 'XML::DOM::Element doc group', - '... otherwise, it should create a new DOM group element' ); - - my $count; - for ( 1 .. 6 ) - { - ( $method, $args ) = $node->next_call(); - $count++ if $method eq 'appendChild'; - } - - is( $count, 6, '... appending each child as a Text node' ); - is( join( ' ', map { $_->[3] } @gbt ), - '3 4 5', '... noted with their node_ids' ); - is( $method, 'appendChild', '... and appending the whole thing' ); - is( $result, $node, '... and should return the new element' ); - } - -} - sub test_clone :Test( 9 ) { my $self = shift; Modified: trunk/ebase/lib/Everything/Node/Test/setting.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/setting.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/Node/Test/setting.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -8,22 +8,6 @@ use Test::More; -sub setup_imports { - - return ('Everything::XML'); -} - -sub test_imports :Test(startup => 1) { - my ( $self) = @_; - my $imports = $self->{imports}; - is_deeply( - $$imports{'Everything::XML'}, - { genBasicTag => 1 }, - '...imports genBasicTag and parseBasicTag from Everything::XML' - ); -} - - sub test_extends :Test( +1 ) { my $self = shift; @@ -77,41 +61,6 @@ ok( $node->hasVars(), 'hasVars() should return true' ); } -sub test_field_to_XML :Test( +5 ) -{ - my $self = shift; - my $node = $self->{node}; - - $self->SUPER(); - - local ( *XML::DOM::Element::new, *XML::DOM::Text::new, - *Everything::Node::setting::genBasicTag, *fieldToXML ); - - my @dom; - *XML::DOM::Element::new = *XML::DOM::Text::new = sub { - push @dom, shift; - return $node; - }; - - my @tags; - *Everything::Node::setting::genBasicTag = sub { - push @tags, join( ' ', @_[ 1 .. 3 ] ); - }; - - $node->set_always( getVars => { a => 1, b => 1, c => 1 } ) - ->set_series( SUPER => 2, 10 ) - ->set_true( '-appendChild' ); - - is( $node->fieldToXML( '', 'vars' ), - $node, '... should return XML::DOM element for vars, if "vars" field' ); - is( @dom, 5, '... should make several DOM nodes:' ); - is( scalar grep( /Element/, @dom ), 1, '... one Element node' ); - is( scalar grep( /Text/, @dom ), 4, '... and several Text nodes' ); - - is( join( '!', @tags ), 'var a 1!var b 1!var c 1', - '... should call genBasicTag() on each var pair' ); -} - sub test_get_node_keep_keys :Test( +1 ) { my $self = shift; Modified: trunk/ebase/lib/Everything/Node/node.pm =================================================================== --- trunk/ebase/lib/Everything/Node/node.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/Node/node.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -15,7 +15,6 @@ use DBI; use Everything qw/$DB/; -use Everything::XML qw/genBasicTag/; use Everything::NodeBase; use Scalar::Util 'reftype'; @@ -457,42 +456,6 @@ return 1; } -=head2 C<fieldToXML> - -Given a field of this node (ie title), convert that field into an XML tag. - -=over 4 - -=item * $DOC - -the base XML::DOM::Document object that this tag belongs to - -=item * $field - -the field of the node to convert - -=item * $indent - -string that contains the amount this tag will be indented. node::fieldToXML -does not use this. This is for more complicated structures that want to have a -nice formatting. This lets them know how far they are going to be indented so -they know how far to indent their children. - -=back - -Returns an XML::DOM::Element object that can be inserted into the parent -structure. - -=cut - -sub fieldToXML -{ - my ( $this, $DOC, $field, $indent ) = @_; - return unless exists $this->{$field}; - - return genBasicTag( $DOC, 'field', $field, $this->{$field} ); -} - =head2 C<getIdentifyingFields> When we export nodes to XML any fields that are pointers to other nodes. A Modified: trunk/ebase/lib/Everything/Node/nodeball.pm =================================================================== --- trunk/ebase/lib/Everything/Node/nodeball.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/Node/nodeball.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -80,22 +80,4 @@ sub hasVars { 1 } -=head2 C<fieldToXML> - -A nodeball has both setting and group type information. A nodeball derives -from nodegroup, but we also need to handle our setting info. The base setting -object will handle that and pass the rest to our parent. - -=cut - -sub fieldToXML -{ - my ( $this, $DOC, $field, $indent ) = @_; - - return Everything::Node::setting::fieldToXML( $this, $DOC, $field, $indent ) - if $field eq 'vars'; - - return $this->SUPER( $DOC, $field, $indent ); -} - 1; Modified: trunk/ebase/lib/Everything/Node/nodegroup.pm =================================================================== --- trunk/ebase/lib/Everything/Node/nodegroup.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/Node/nodegroup.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -13,9 +13,6 @@ use base 'Everything::Node::node'; -use Everything::XML (qw/genBasicTag/); - -use XML::DOM; use Scalar::Util 'reftype'; sub construct @@ -633,52 +630,6 @@ return $keys; } -=head2 C<fieldToXML> - -Convert the field that contains the group structure to an XML format. - -=over 4 - -=item * $DOC - -the base XML::DOM::Document object that contains this structure - -=item * $field - -the field of the node to convert (if it is not the group field, we just call -SUPER()) - -=item * $indent - -string that contains the spaces that this will be indented - -=back - -=cut - -sub fieldToXML -{ - my ( $this, $DOC, $field, $indent ) = @_; - - return $this->SUPER( $DOC, $field, $indent ) unless $field eq 'group'; - - my $GROUP = XML::DOM::Element->new( $DOC, 'group' ); - my $indentself = "\n" . $indent; - my $indentchild = $indentself . " "; - - for my $member ( @{ $this->{group} } ) - { - $GROUP->appendChild( XML::DOM::Text->new( $DOC, $indentchild ) ); - - my $tag = genBasicTag( $DOC, 'member', 'group_node', $member ); - $GROUP->appendChild($tag); - } - - $GROUP->appendChild( XML::DOM::Text->new( $DOC, $indentself ) ); - - return $GROUP; -} - =head2 C<clone> Clone the node! The normal clone doesn't duplicate members of a nodegroup, so Modified: trunk/ebase/lib/Everything/Node/setting.pm =================================================================== --- trunk/ebase/lib/Everything/Node/setting.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/Node/setting.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -14,8 +14,6 @@ use base 'Everything::Node::node'; use Everything::Security; -use Everything::XML (qw/genBasicTag/); -use XML::DOM; use Scalar::Util 'reftype'; =head2 C<dbtables()> @@ -75,60 +73,6 @@ sub hasVars { 1 } -=head2 C<fieldToXML> - -This is called when the node is being exported to XML. The base node knows how -to export fields to XML, but if the node contains some more complex data -structures, that nodetype needs to export that data structure itself. In this -case, we have a settings field (hash) that needs to get exported. - -=over 4 - -=item * $DOC - -an XML::DOM::Document object that this field belongs to - -=item * $field - -the field of this node that needs to be exported as XML - -=item * $indent - -string that contains the amount that this will be indented (used for formatting -purposes) - -=back - -Returns the XML::DOM::Element that represents this field. - -=cut - -sub fieldToXML -{ - my ( $this, $DOC, $field, $indent ) = @_; - $indent ||= ''; - - return $this->SUPER( $DOC, $field, $indent ) unless $field eq 'vars'; - - my $VARS = XML::DOM::Element->new( $DOC, "vars" ); - my $vars = $this->getVars(); - my @raw = keys %$vars; - my @vars = sort { $a cmp $b } @raw; - my $indentself = "\n" . $indent; - my $indentchild = $indentself . " "; - - foreach my $var (@vars) - { - $VARS->appendChild( XML::DOM::Text->new( $DOC, $indentchild ) ); - my $tag = genBasicTag( $DOC, "var", $var, $$vars{$var} ); - $VARS->appendChild($tag); - } - - $VARS->appendChild( XML::DOM::Text->new( $DOC, $indentself ) ); - - return $VARS; -} - sub getNodeKeepKeys { my ($this) = @_; Modified: trunk/ebase/lib/Everything/Test/XML.pm =================================================================== --- trunk/ebase/lib/Everything/Test/XML.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/Test/XML.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -258,121 +258,6 @@ ); } -### genBasicTag -# is passed $doc, $tagname, $fieldname, $content -# -# $doc is a XML::DOM::Document object and here is a mock -# $tagname is a string of what whe want to call the XML tag -# -# fieldname is the field of the node that we are encoding -# content is the actual content that we are encoding -# -# if fieldname is preceded by an underscore it is assumed content is a -# noderef pointing to a type - -sub test_gen_basic_tag : Test(15) { - my $self = shift; - my $package = $self->{class}; - can_ok( $package, 'genBasicTag' ) || return "Can't genBasicTag"; - - my $mock = $self->{mock}; - $mock->clear; - - $mock->fake_module('XML::DOM::Element'); - $mock->fake_new('XML::DOM::Element'); - $mock->fake_module('XML::DOM::Text'); - $mock->fake_new('XML::DOM::Text'); - - $mock->set_true( 'setAttribute', 'appendChild', '-isOfType' ); - $mock->set_always( 'getIdentifyingFields', ['identifyingfield'] ); - $mock->{type}->{title} = "a_type_title"; - my (@gn); - no strict 'refs'; - - local *genBasicTag = \&{ $self->{class} . '::genBasicTag' }; - local *{ $package . '::getNode' }; - *{ $package . '::getNode' } = sub { - push @gn, [@_]; - return $mock; - }; - local *{ $package . '::makeXmlSafe' }; - *{ $package . '::makeXmlSafe' } = sub { - push @gn, [@_]; - return $_[0]; - }; - - local *{ $package . '::getRef' }; - *{ $package . '::getRef' } = sub { - $mock->{node_id} = $_[0]; - $_[0] = $mock; - }; - use strict 'refs'; - - my $result = genBasicTag( - $mock, - "amazing tag name", - "node field name", - "stupendous content" - ); - - my ( $method, $args ) = $mock->next_call; - is( $method, 'setAttribute', '...sets tag attributes.' ); - is_deeply( - $args, - [ $mock, 'name', 'node field name' ], - '...and set it properly.' - ); - - ( $method, $args ) = $mock->next_call; - is( $method, 'setAttribute', '...sets next tag attributes.' ); - is_deeply( - $args, - [ $mock, 'type', 'literal_value' ], - '...and sets it to literal value.' - ); - - ( $method, $args ) = $mock->next_call; - is( $method, 'appendChild', '...adds it to the tag.' ); - is_deeply( $args, [ $mock, $mock ], '...with the correct content.' ); - is( $result, $mock, '...should return a tag' ); - - $mock->{identifyingfield} = 111; - $result = genBasicTag( $mock, "amazing tag name", "_nodefieldname", "112" ); - - ( $method, $args ) = $mock->next_call; - is( $method, 'getIdentifyingFields', - '...checks identifying fields if node has some.' ); - ( $method, $args ) = $mock->next_call; - is( $method, 'setAttribute', '...sets tag attributes.' ); - is_deeply( - $args, - [ $mock, 'identifyingfield', 111 ], - '...with identifying fields' - ); - - $mock->clear; - @gn = (); - $mock->{_identifyingfield} = 222; - $mock->{title} = 'a random title'; - $mock->{type}->{title} = 'a type name'; - $mock->set_always( 'getIdentifyingFields', ['_identifyingfield'] ); - $result = genBasicTag( $mock, "amazing tag name", "_nodefieldname", "112" ); - - ( $method, $args ) = $mock->next_call; - is( $method, 'getIdentifyingFields', - '...checks identifying fields if noderef.' ); - ( $method, $args ) = $mock->next_call; - is( $method, 'setAttribute', '...sets tag attributes with node ref.' ); - is_deeply( - $args, - [ $mock, '_identifyingfield', 'a random title,a type name' ], - '...with fields by type and name.' - ); - - is_deeply( $gn[2], [222], - '...and calls get node with the identifying field' ); -} - ### parseBasicTag plan: # # arguments: $TAG, which is a XML::DOM::Element object here $mock @@ -529,18 +414,6 @@ is_deeply( $result, { _akey => 'avalue' }, '...the hash is not amended.' ); } -sub test_make_xml_safe : Test(2) { - my $self = shift; - my $package = $self->{class}; - can_ok( $package, 'makeXmlSafe' ) || return; - *makeXmlSafe = \&{ $self->{class} . '::makeXmlSafe' }; - is( - makeXmlSafe('& > <'), - '& > <', - '...encodes a few XML character entities.' - ); -} - sub test_unmake_xml_safe : Test(2) { my $self = shift; my $package = $self->{class}; Added: trunk/ebase/lib/Everything/XML/Node.pm =================================================================== --- trunk/ebase/lib/Everything/XML/Node.pm (rev 0) +++ trunk/ebase/lib/Everything/XML/Node.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -0,0 +1,313 @@ +package Everything::XML::Node; + +{ + use Object::InsideOut; + + my @node + :Field + :Standard(node) + :Arg(node); + + my @nodebase + :Field + :Standard(nodebase) + :Arg(nodebase); + +} + + +=head2 C<fieldToXML_vars> + +This is called when the node is being exported to XML and the field we +are creating is a var field. The base node knows how to export fields +to XML, but if the node contains some more complex data structures, +that nodetype needs to export that data structure itself. In this +case, we have a settings field (hash) that needs to get exported. + +=over 4 + +=item * $DOC + +an XML::DOM::Document object that this field belongs to + +=item * $field + +the field of this node that needs to be exported as XML + +=item * $indent + +string that contains the amount that this will be indented (used for formatting +purposes) + +=back + +Returns the XML::DOM::Element that represents this field. + +=cut + +sub fieldToXML_vars +{ + my ( $this, $DOC, $field, $indent ) = @_; + $indent ||= ''; + + my $VARS = XML::DOM::Element->new( $DOC, "vars" ); + my $vars = $this->get_node->getVars(); + my @raw = keys %$vars; + my @vars = sort { $a cmp $b } @raw; + my $indentself = "\n" . $indent; + my $indentchild = $indentself . " "; + + foreach my $var (@vars) + { + $VARS->appendChild( XML::DOM::Text->new( $DOC, $indentchild ) ); + my $tag = genBasicTag( $DOC, "var", $var, $$vars{$var} ); + $VARS->appendChild($tag); + } + + $VARS->appendChild( XML::DOM::Text->new( $DOC, $indentself ) ); + + return $VARS; +} + + +=head2 C<fieldToXML_group> + +Convert the field that contains the group structure to an XML format. + +=over 4 + +=item * $DOC + +the base XML::DOM::Document object that contains this structure + +=item * $field + +the field of the node to convert (if it is not the group field, we just call +SUPER()) + +=item * $indent + +string that contains the spaces that this will be indented + +=back + +=cut + +sub fieldToXML_group +{ + my ( $this, $DOC, $field, $indent ) = @_; + + my $GROUP = XML::DOM::Element->new( $DOC, 'group' ); + my $indentself = "\n" . $indent; + my $indentchild = $indentself . " "; + + for my $member ( @{ $this->get_node->{group} } ) + { + $GROUP->appendChild( XML::DOM::Text->new( $DOC, $indentchild ) ); + + my $tag = $this->genBasicTag( $DOC, 'member', 'group_node', $member ); + $GROUP->appendChild($tag); + } + + $GROUP->appendChild( XML::DOM::Text->new( $DOC, $indentself ) ); + + return $GROUP; +} + + +sub fieldToXML_field { + + my ( $this, $DOC, $field, $indent ) = @_; + return $this->genBasicTag( $DOC, 'field', $field, $this->get_node->{$field} ); +} + +=head2 C<fieldToXML> + +Given a field of this node (ie title), convert that field into an XML tag. + +=over 4 + +=item * $DOC + +the base XML::DOM::Document object that this tag belongs to + +=item * $field + +the field of the node to convert + +=item * $indent + +string that contains the amount this tag will be indented. node::fieldToXML +does not use this. This is for more complicated structures that want to have a +nice formatting. This lets them know how far they are going to be indented so +they know how far to indent their children. + +=back + +Returns an XML::DOM::Element object that can be inserted into the parent +structure. + +=cut + +sub fieldToXML +{ + my ( $this, $DOC, $field, $indent ) = @_; + return unless exists $this->get_node->{$field}; + + my %dispatches = ( field => \&fieldToXML_field, + group => \&fieldToXML_group, + vars => \&fieldToXML_vars, + ); + + my $sub = $dispatches{$field} || $dispatches{'field'}; + return $sub->(@_); +} + + +=head2 C<genBasicTag> + +For most fields in a node, there are 2 types that the field could be. Either a +literal value, or a reference to a node. This function will generate the tag +based on the fieldname and the content. + +=over 4 + +=item * $doc + +the root document node for which this new tag belongs + +=item * $tagname + +the name of the xml tag + +=item * $fieldname + +the name of the field + +=item * $content + +the content of the tag + +=back + + E<lt>tagname name="fieldname" *generated params*E<gt>contentE<lt>/tagnameE<gt> + +Returns the generated XML tag. + +=cut + +sub genBasicTag +{ + my ( $this, $doc, $tagname, $fieldname, $content ) = @_; + my $db = $this->get_nodebase; + my $isRef = 0; + my $isNum = 0; + my $type; + my $xml; + my $PARAMS = { name => $fieldname }; + my $data; + + # Check to see if the field name ends with a "_typename" + if ( $fieldname =~ /_(\w+)$/ ) + { + $type = $1; + + # if the numeric value is not greater than zero, it is a literal value. + # Nodes cannot have an id of less than 1. + $isRef = 1 if $content !~ /\D/ && $content > 0 && $db->getRef($content); + } + + if ($isRef) + { + + # This field references a node + my $REF = $db->getNode($content); + + unless ( $REF->isOfType( $type, 1 ) ) + { + Everything::logErrors( "Field '$fieldname' needs a node of type " + . "'$type',\nbut it is pointing to a node of type " + . "'$REF->{type}{title}'!" ); + } + + $data = makeXmlSafe( $$REF{title} ); + @$PARAMS{qw( type type_nodetype )} = + ( 'noderef', "$REF->{type}{title},nodetype" ); + + # Merge the standard title/type with any unique identifiers given + # by the node. + my $ID = $REF->getIdentifyingFields() || (); + + foreach my $id (@$ID) + { + if ( $id =~ /_(\w*)$/ ) + { + my $N = $db->getNode( $REF->{$id} ); + $PARAMS->{$id} = "$N->{title},$N->{type}{title}"; + } + else + { + $PARAMS->{$id} = $REF->{$id}; + } + } + } + else + { + + # This is just a literal value + $data = $content; + $PARAMS->{type} = 'literal_value'; + } + + # Now that we have gathered the attributes and data for this tag, we + # need to construct it. + my $tag = XML::DOM::Element->new( $doc, $tagname ); + my $contents = XML::DOM::Text->new( $doc, $data ); + + # Set the attributes on the tag. We sort the keys so that the + # attributes come out in an ordered fashion. That way we won't + # get merge conflicts in CVS due to seemingly random order of + # the attributes + my @sortAttrs = sort { $a cmp $b } keys %$PARAMS; + foreach my $param (@sortAttrs) + { + $tag->setAttribute( $param, $PARAMS->{$param} ); + } + + # And insert the content into our tag + $tag->appendChild($contents); + + return $tag; +} + + + +=head2 C<makeXmlSafe> + +Make a string not interfere with the xml + +=over 4 + +=item * $str + +the literal string + +=back + +Returns the encoded string. + +=cut + +sub makeXmlSafe +{ + my ($str) = @_; + + #we use an HTML convention... + $str =~ s/\&/\&\;/g; + $str =~ s/\</\<\;/g; + $str =~ s/\>/\>\;/g; + + return $str; +} + +1; Property changes on: trunk/ebase/lib/Everything/XML/Node.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Added: trunk/ebase/lib/Everything/XML/Test/Node.pm =================================================================== --- trunk/ebase/lib/Everything/XML/Test/Node.pm (rev 0) +++ trunk/ebase/lib/Everything/XML/Test/Node.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -0,0 +1,293 @@ +package Everything::XML::Test::Node; + +use base 'Test::Class'; +use Test::More; +use Test::MockObject; +use Test::MockObject::Extends; +use Scalar::Util qw/blessed/; +use strict; +use warnings; + +sub object_class { + my $self = shift; + my $name = blessed($self); + $name =~ s/Test:://; + return $name; +} + +sub startup : Test(2) { + my $self = shift; + my $class = $self->object_class; + use_ok($class); + isa_ok( $class->new(), $class ); + $self->{class} = $class; + $self->{instance} = $class->new; +} + +sub test_field_to_XML : Test( 5 ) { + my $self = shift; + my $class = $self->{class}; + my $instance = $self->{instance}; + + my $node = Test::MockObject->new; + $instance->set_node($node); + my @gbt; + + no strict 'refs'; + local *{ $class . '::genBasicTag' }; + *{ $class . '::genBasicTag' } = sub { + push @gbt, [@_]; + 'tag'; + }; + use strict 'refs'; + + $node->{afield} = 'thisfield'; + is( $instance->fieldToXML( $node, 'afield' ), + 'tag', 'fieldToXML() should return an XML tag element' ); + is( @gbt, 1, '... and should call genBasicTag()' ); + is( + join( ' ', @{ $gbt[0] } ), + "$instance $node field afield thisfield", + '... with the correct arguments' + ); + + ok( + !$instance->fieldToXML( $instance, 'notafield' ), + '... and should return false if field does not exist' + ); + ok( !exists $node->{notafield}, '... and should not create field' ); +} + +sub test_field_to_XML_vars : Test( 5 ) { + my $self = shift; + my $instance = $self->{instance}; + my $mock = Test::MockObject->new; + $instance->set_node($mock); + $instance->set_nodebase($mock); + + $mock->{vars} = 'a var'; + + local ( *XML::DOM::Element::new, *XML::DOM::Text::new, + *Everything::XML::Node::genBasicTag, *fieldToXML ); + + my @dom; + *XML::DOM::Element::new = *XML::DOM::Text::new = sub { + push @dom, shift; + return $mock; + }; + + my @tags; + *Everything::XML::Node::genBasicTag = sub { + push @tags, join( ' ', @_[ 1 .. 3 ] ); + }; + + $mock->set_always( getVars => { a => 1, b => 1, c => 1 } ) + ->set_true('-appendChild'); + + is( $instance->fieldToXML( '', 'vars' ), + $mock, '... should return XML::DOM element for vars, if "vars" field' ); + is( @dom, 5, '... should make several DOM nodes:' ); + is( scalar grep( /Element/, @dom ), 1, '... one Element node' ); + is( scalar grep( /Text/, @dom ), 4, '... and several Text nodes' ); + + is( + join( '!', @tags ), + 'var a 1!var b 1!var c 1', + '... should call genBasicTag() on each var pair' + ); +} + +sub test_field_to_XML_group : Test( 5 ) { + my $self = shift; + my $instance = $self->{instance}; + my $mock = Test::MockObject->new; + $mock->set_true('appendChild'); + $instance->set_node($mock); + $instance->set_nodebase($mock); + $mock->set_true( 'getRef', 'setAttribute', 'isOfType' ); + $mock->set_always( 'getNode', $mock ); + $mock->set_always( 'getIdentifyingFields', ['identifyingfield'] ); + + my $result = $instance->fieldToXML( 'doc', 'field', 0 ); + my ( $method, $args ); + + { + local ( *XML::DOM::Element::new, *XML::DOM::Text::new, + *Everything::XML::Node::genBasicTag ); + + my @xd; + *XML::DOM::Text::new = sub { + push @xd, [@_]; + return @_; + }; + *XML::DOM::Element::new = sub { + push @xd, [@_]; + return $mock; + }; + + my @gbt; + *Everything::XML::Node::genBasicTag = sub { + push @gbt, [@_]; + }; + + $mock->{group} = [ 3, 4, 5 ]; + $result = $instance->fieldToXML( 'doc', 'group', "\r" ); + + is( + join( ' ', @{ $xd[0] } ), + 'XML::DOM::Element doc group', + '... it should create a new DOM group element' + ); + + my $count; + for ( 1 .. 6 ) { + ( $method, $args ) = $mock->next_call(); + $count++ if $method eq 'appendChild'; + } + + is( $count, 6, '... appending each child as a Text node' ); + is( join( ' ', map { $_->[4] } @gbt ), + '3 4 5', '... noted with their node_ids' ); + is( $method, 'appendChild', '... and appending the whole thing' ); + is( $result, $mock, '... and should return the new element' ); + } + +} + +### genBasicTag +# is passed $doc, $tagname, $fieldname, $content +# +# $doc is a XML::DOM::Document object and here is a mock +# $tagname is a string of what whe want to call the XML tag +# +# fieldname is the field of the node that we are encoding +# content is the actual content that we are encoding +# +# if fieldname is preceded by an underscore it is assumed content is a +# noderef pointing to a type + +sub test_gen_basic_tag : Test(15) { + my $self = shift; + my $package = $self->{class}; + my $instance = $self->{instance}; + can_ok( $package, 'genBasicTag' ) || return "Can't genBasicTag"; + + my $mock = Test::MockObject->new; + + $instance->set_node($mock); + $instance->set_nodebase($mock); + + $mock->fake_module('XML::DOM::Element'); + $mock->fake_new('XML::DOM::Element'); + $mock->fake_module('XML::DOM::Text'); + $mock->fake_new('XML::DOM::Text'); + + $mock->set_true( 'setAttribute', 'appendChild', '-isOfType', '-getRef' ); + $mock->set_always( 'getIdentifyingFields', ['identifyingfield'] ); + $mock->{type}->{title} = "a_type_title"; + my (@gn); + + $mock->mock( + -getNode => sub { + push @gn, [@_]; + return $mock; + } + ); + no strict 'refs'; + local *{ $package . '::makeXmlSafe' }; + *{ $package . '::makeXmlSafe' } = sub { + push @gn, [@_]; + return $_[0]; + }; + + local *{ $package . '::getRef' }; + *{ $package . '::getRef' } = sub { + $mock->{node_id} = $_[0]; + $_[0] = $mock; + }; + use strict 'refs'; + + my $result = $instance->genBasicTag( + $mock, + "amazing tag name", + "node field name", + "stupendous content" + ); + + my ( $method, $args ) = $mock->next_call; + is( $method, 'setAttribute', '...sets tag attributes.' ); + is_deeply( + $args, + [ $mock, 'name', 'node field name' ], + '...and set it properly.' + ); + + ( $method, $args ) = $mock->next_call; + is( $method, 'setAttribute', '...sets next tag attributes.' ); + is_deeply( + $args, + [ $mock, 'type', 'literal_value' ], + '...and sets it to literal value.' + ); + + ( $method, $args ) = $mock->next_call; + is( $method, 'appendChild', '...adds it to the tag.' ); + is_deeply( $args, [ $mock, $mock ], '...with the correct content.' ); + is( $result, $mock, '...should return a tag' ); + + $mock->{identifyingfield} = 111; + $result = $instance->genBasicTag( $mock, "amazing tag name", + "_nodefieldname", "112" ); + + ( $method, $args ) = $mock->next_call; + is( $method, 'getIdentifyingFields', + '...checks identifying fields if node has some.' ); + ( $method, $args ) = $mock->next_call; + is( $method, 'setAttribute', '...sets tag attributes.' ); + is_deeply( + $args, + [ $mock, 'identifyingfield', 111 ], + '...with identifying fields' + ); + + $mock->clear; + @gn = (); + $mock->{_identifyingfield} = 222; + $mock->{title} = 'a random title'; + $mock->{type}->{title} = 'a type name'; + $mock->set_always( 'getIdentifyingFields', ['_identifyingfield'] ); + $result = $instance->genBasicTag( $mock, "amazing tag name", + "_nodefieldname", "112" ); + + ( $method, $args ) = $mock->next_call; + is( $method, 'getIdentifyingFields', + '...checks identifying fields if noderef.' ); + ( $method, $args ) = $mock->next_call; + is( $method, 'setAttribute', '...sets tag attributes with node ref.' ); + is_deeply( + $args, + [ $mock, '_identifyingfield', 'a random title,a type name' ], + '...with fields by type and name.' + ); + + is_deeply( + $gn[-1], + [ $mock, 222 ], + '...and calls get node with the identifying field' + ); +} + + +sub test_make_xml_safe : Test(2) { + my $self = shift; + my $package = $self->{class}; + can_ok( $package, 'makeXmlSafe' ) || return; + *makeXmlSafe = \&{ $self->{class} . '::makeXmlSafe' }; + is( + makeXmlSafe('& > <'), + '& > <', + '...encodes a few XML character entities.' + ); +} + +1; Property changes on: trunk/ebase/lib/Everything/XML/Test/Node.pm ___________________________________________________________________ Name: svn:mime-type + text/plain Name: svn:eol-style + native Modified: trunk/ebase/lib/Everything/XML.pm =================================================================== --- trunk/ebase/lib/Everything/XML.pm 2007-01-03 19:47:06 UTC (rev 932) +++ trunk/ebase/lib/Everything/XML.pm 2007-01-03 19:47:50 UTC (rev 933) @@ -496,123 +496,6 @@ =cut -=head2 C<genBasicTag> - -For most fields in a node, there are 2 types that the field could be. Either a -literal value, or a reference to a node. This function will generate the tag -based on the fieldname and the content. - -=over 4 - -=item * $doc - -the root document node for which this new tag belongs - -=item * $tagname - -the name of the xml tag - -=item * $fieldname - -the name of the field - -=item * $content - -the content of the tag - -=back - - E<lt>tagname name="fieldname" *generated params*E<gt>contentE<lt>/tagnameE<gt> - -Returns the generated XML tag. - -=cut - -sub genBasicTag -{ - my ( $doc, $tagname, $fieldname, $content ) = @_; - my $isRef = 0; - my $isNum = 0; - my $type; - my $xml; - my $PARAMS = { name => $fieldname }; - my $data; - - # Check to see if the field name ends with a "_typename" - if ( $fieldname =~ /_(\w+)$/ ) - { - $type = $1; - - # if the numeric value is not greater than zero, it is a literal value. - # Nodes cannot have an id of less than 1. - $isRef = 1 if $content !~ /\D/ && $content > 0 && getRef($content); - } - - if ($isRef) - { - - # This field references a node - my $REF = getNode($content); - - unless ( $REF->isOfType( $type, 1 ) ) - { - Everything::logErrors( "Field '$fieldname' needs a node of type " - . "'$type',\nbut it is pointing to a node of type " - . "'$REF->{type}{title}'!" ); - } - - $data = makeXmlSafe( $$REF{title} ); - @$PARAMS{qw( type type_nodetype )} = - ( 'noderef', "$REF->{type}{title},nodetype" ); - - # Merge the standard title/type with any unique identifiers given - # by the node. - my $ID = $REF->getIdentifyingFields() || (); - - foreach my $id (@$ID) - { - if ( $id =~ /_(\w*)$/ ) - { - my $N = getNode( $REF->{$id} ); - $PARAMS->{$id} = "$N->{title},$N->{type}{title}"; - } - else - { - $PARAMS->{$id} = $REF->{$id}; - } - } - } - else - { - - # This is just a literal value - $data = $content; - $PARAMS->{type} = 'literal_value'; - } - - # Now that we have gathered the attributes and data for this tag, we - # need to construct it. - my $tag = XML::DOM::Element->new( $doc, $tagname ); - my $contents = XML::DOM::Text->new( $doc, $data ); - - # Set the attributes on the tag. We sort the keys so that the - # attributes come out in an ordered fashion. That way we won't - # get merge conflicts in CVS due to seemingly random order of - # the attributes - my @sortAttrs = sort { $a cmp $b } keys %$PARAMS; - foreach my $param (@sortAttrs) - { - $tag->setAttribute( $param, $PARAMS->{$param} ); - } - - # And insert the content into our tag - $tag->appendChild($contents); - - return $tag; -} - -=cut - =head2 C<xmlFinal> This is called when a node has finished being constructed from an XML import. @@ -773,37 +656,9 @@ =cut -=head2 C<makeXmlSafe> - -Make a string not interfere with the xml - -=over 4 - -=item * $str - -the literal string - -=back - -Returns the encoded string. - =cut -sub makeXmlSafe -{ - my ($str) = @_; - #we use an HTML convention... - $str =~ s/\&/\&\;/g; - $str =~ s/\</\<\;/g; - $str =~ s/\>/\>\;/g; - - return $str; -} - -=cut - - =head2 C<unMakeXmlSafe> Decode something encoded by makeXmlSafe This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2007-01-03 19:48:11
|
Revision: 934 http://svn.sourceforge.net/everydevel/?rev=934&view=rev Author: paul_the_nomad Date: 2007-01-03 11:48:10 -0800 (Wed, 03 Jan 2007) Log Message: ----------- Node.pm toXML test Modified Paths: -------------- trunk/ebase/lib/Everything/Test/Node.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:936 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 + 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:937 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/lib/Everything/Test/Node.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Node.pm 2007-01-03 19:47:50 UTC (rev 933) +++ trunk/ebase/lib/Everything/Test/Node.pm 2007-01-03 19:48:10 UTC (rev 934) @@ -2,6 +2,7 @@ use Test::More; use Test::MockObject; +use Test::MockObject::Extends; use Scalar::Util qw/blessed/; use base 'Test::Class'; use strict; @@ -271,10 +272,32 @@ } -sub test_to_xML : Test(1) { +sub test_to_xml : Test(5) { my $self = shift; can_ok( $self->{class}, 'toXML' ) || return; + my $instance = Test::MockObject::Extends->new($self->{instance}); + $instance->set_always(getNodeKeys => { key1 => 'value1', key2 => 'value2'} ); + $instance->set_always(fieldToXML => 'a tag' ); + + my $mock = $self->{mock}; + $mock->fake_module('XML::DOM::Document'); + $mock->fake_module('XML::DOM::Text'); + $mock->fake_new('XML::DOM::Document'); + $mock->fake_new('XML::DOM::Text'); + $mock->fake_new('XML::DOM::Element'); + $mock->fake_new('XML::DOM::Element'); + + $mock->set_true('-setAttribute', '-appendChild'); + $mock->set_always('toString', 'a string of xml'); + is ($instance->toXML, 'a string of xml', '...should return XML.'); + my ($method, $args) = $instance->next_call; + + is($method, 'getNodeKeys', '...should get exportable keys from node object.'); + + ($method, $args) = $instance->next_call; + is ($method, 'fieldToXML', '...asks for field in XML.'); + is_deeply ($args, [$instance, $mock, 'key1', ' '], '...with arguments.'); } sub test_existing_node_matches : Test(1) { This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2007-01-03 19:48:47
|
Revision: 935 http://svn.sourceforge.net/everydevel/?rev=935&view=rev Author: paul_the_nomad Date: 2007-01-03 11:48:46 -0800 (Wed, 03 Jan 2007) Log Message: ----------- Move toXML out of node hierarchy to XML/Node.pm Modified Paths: -------------- trunk/ebase/lib/Everything/Node/Test/node.pm trunk/ebase/lib/Everything/Node/node.pm trunk/ebase/lib/Everything/Node.pm trunk/ebase/lib/Everything/Nodeball.pm trunk/ebase/lib/Everything/Test/Node.pm trunk/ebase/lib/Everything/XML/Node.pm trunk/ebase/lib/Everything/XML/Test/Node.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:937 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 + 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:938 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/lib/Everything/Node/Test/node.pm =================================================================== --- trunk/ebase/lib/Everything/Node/Test/node.pm 2007-01-03 19:48:10 UTC (rev 934) +++ trunk/ebase/lib/Everything/Node/Test/node.pm 2007-01-03 19:48:46 UTC (rev 935) @@ -38,12 +38,15 @@ push @{ $self->{errors} }, [@_]; } ); + *Everything::Node::node::DB = \$mock; my $module = $self->node_class(); my %import; my $mockimport = sub { + return unless (caller)[0] eq $module; # don't report imports + # from other packages $import{ +shift } = { map { $_ => 1 } @_[ 1 .. $#_ ] }; }; @@ -62,20 +65,10 @@ sub setup_imports { - return qw( DBI Everything ); + my $self = shift; + (); } -sub test_imports :Test(startup => 1) { - my ( $self) = @_; - my $imports = $self->{imports}; - is_deeply( - $$imports{Everything}, - { '$DB' => 1}, - '...imports $DB from Everything' - ); - -} - sub make_base_test_db { my $self = shift; @@ -602,6 +595,9 @@ $node->{type}{maxrevisions} = 0; + $node->fake_module('Everything::XML::Node', new => sub { $node }); + $node->set_true('toXML'); + my $result = $node->logRevision( 'user' ); is( $result, 0, 'logRevisions() should return 0 if lacking max revisons' ); @@ -681,6 +677,9 @@ $node->set_true( 'setVars' ); + $node->fake_module('Everything::XML::Node', new => sub { $node }); + $node->set_true('toXML'); + my $position = \$db->{workspace}{nodes}{13}; $$position = 4; my $result = $node->undo( 'user', 1, 1 ); Modified: trunk/ebase/lib/Everything/Node/node.pm =================================================================== --- trunk/ebase/lib/Everything/Node/node.pm 2007-01-03 19:48:10 UTC (rev 934) +++ trunk/ebase/lib/Everything/Node/node.pm 2007-01-03 19:48:46 UTC (rev 935) @@ -15,7 +15,9 @@ use DBI; use Everything qw/$DB/; +use Everything::XML 'xml2node'; use Everything::NodeBase; +use Everything::XML::Node; use Scalar::Util 'reftype'; @@ -729,8 +731,8 @@ } my $data = $workspace - ? $this->toXML() - : $this->{DB}->getNode( $this->getId, 'force' )->toXML(); + ? Everything::XML::Node->new( node => $this, nodebase => $this->{DB} )->toXML + : Everything::XML::Node->new( node => $this->{DB}->getNode( $this->getId, 'force'), nodebase => $this->{DB} )->toXML(); my $rev_id = $DB->sqlSelect( 'max(revision_id)+1', 'revision', @@ -870,7 +872,7 @@ # prepare the redo/undo (inverse of what's being called) - $REVISION->{xml} = $this->toXML(); + $REVISION->{xml} = Everything::XML::Node->new(node => $this, nodebase => $this->{DB} )->toXML(); $REVISION->{revision_id} = -$revision_id; my ($NEWNODE) = @{ xml2node($xml) }; Modified: trunk/ebase/lib/Everything/Node.pm =================================================================== --- trunk/ebase/lib/Everything/Node.pm 2007-01-03 19:48:10 UTC (rev 934) +++ trunk/ebase/lib/Everything/Node.pm 2007-01-03 19:48:46 UTC (rev 935) @@ -1166,64 +1166,7 @@ =cut -=head2 C<toXML> -This returns a string that contains an XML representation for this node. -Basically a way to export this node. - -We use the XML::Generator to create the XML because the XML::DOM API is not -very friendly for creating XML documents as it is for reading them. - -Returns the XML string. - -=cut - -sub toXML -{ - my ($this) = @_; - my $DOC = new XML::DOM::Document(); - my $NODE; - my $exportFields = $this->getNodeKeys(1); - my $tag; - my @fields; - my @rawFields; - - push @rawFields, keys %$exportFields; - - # This is used to determine if our parser can read in a particular - # export. If the parser is upgraded/modified, this should be bumped - # so that older versions of this code will know that it may have - # problems reading in XML that generated by a newer version. - my $XMLVERSION = "0.5"; - - $NODE = new XML::DOM::Element( $DOC, "NODE" ); - - $NODE->setAttribute( "export_version", $XMLVERSION ); - $NODE->setAttribute( "nodetype", $$this{type}{title} ); - $NODE->setAttribute( "title", $$this{title} ); - - # Sort them so that the exported XML has some order to it. - @fields = sort { $a cmp $b } @rawFields; - - foreach my $field (@fields) - { - $NODE->appendChild( new XML::DOM::Text( $DOC, "\n " ) ); - - $tag = $this->fieldToXML( $DOC, $field, " " ); - $NODE->appendChild($tag); - } - - $NODE->appendChild( new XML::DOM::Text( $DOC, "\n" ) ); - - $DOC->appendChild($NODE); - - # Return the structure as a string - return $DOC->toString(); -} - -=cut - - =head2 C<existingNodeMatches> Mainly used for importing purposes to see of a node matching this one already Modified: trunk/ebase/lib/Everything/Nodeball.pm =================================================================== --- trunk/ebase/lib/Everything/Nodeball.pm 2007-01-03 19:48:10 UTC (rev 934) +++ trunk/ebase/lib/Everything/Nodeball.pm 2007-01-03 19:48:46 UTC (rev 935) @@ -575,7 +575,8 @@ # a new node to the file. open( FILE, ">>" . $file ) or die "couldn't create $file in $dir - do we have permission?"; - print FILE $NODE->toXML(); + my $xmlifier = Everything::XML::Node->new(node => $NODE, nodebase => $DB ); + print FILE $xmlifier->toXML(); close(FILE); Modified: trunk/ebase/lib/Everything/Test/Node.pm =================================================================== --- trunk/ebase/lib/Everything/Test/Node.pm 2007-01-03 19:48:10 UTC (rev 934) +++ trunk/ebase/lib/Everything/Test/Node.pm 2007-01-03 19:48:46 UTC (rev 935) @@ -272,34 +272,7 @@ } -sub test_to_xml : Test(5) { - my $self = shift; - can_ok( $self->{class}, 'toXML' ) || return; - my $instance = Test::MockObject::Extends->new($self->{instance}); - $instance->set_always(getNodeKeys => { key1 => 'value1', key2 => 'value2'} ); - $instance->set_always(fieldToXML => 'a tag' ); - - my $mock = $self->{mock}; - $mock->fake_module('XML::DOM::Document'); - $mock->fake_module('XML::DOM::Text'); - $mock->fake_new('XML::DOM::Document'); - $mock->fake_new('XML::DOM::Text'); - $mock->fake_new('XML::DOM::Element'); - $mock->fake_new('XML::DOM::Element'); - - $mock->set_true('-setAttribute', '-appendChild'); - $mock->set_always('toString', 'a string of xml'); - is ($instance->toXML, 'a string of xml', '...should return XML.'); - my ($method, $args) = $instance->next_call; - - is($method, 'getNodeKeys', '...should get exportable keys from node object.'); - - ($method, $args) = $instance->next_call; - is ($method, 'fieldToXML', '...asks for field in XML.'); - is_deeply ($args, [$instance, $mock, 'key1', ' '], '...with arguments.'); -} - sub test_existing_node_matches : Test(1) { my $self = shift; can_ok( $self->{class}, 'existingNodeMatches' ) || return; Modified: trunk/ebase/lib/Everything/XML/Node.pm =================================================================== --- trunk/ebase/lib/Everything/XML/Node.pm 2007-01-03 19:48:10 UTC (rev 934) +++ trunk/ebase/lib/Everything/XML/Node.pm 2007-01-03 19:48:46 UTC (rev 935) @@ -1,3 +1,9 @@ +=head1 Everything::XML::Node + +A package to turn nodes into XML for exporting to Nodeballs and revisions. + +=cut + package Everything::XML::Node; { @@ -19,10 +25,7 @@ =head2 C<fieldToXML_vars> This is called when the node is being exported to XML and the field we -are creating is a var field. The base node knows how to export fields -to XML, but if the node contains some more complex data structures, -that nodetype needs to export that data structure itself. In this -case, we have a settings field (hash) that needs to get exported. +are creating is a var field. =over 4 @@ -60,7 +63,7 @@ foreach my $var (@vars) { $VARS->appendChild( XML::DOM::Text->new( $DOC, $indentchild ) ); - my $tag = genBasicTag( $DOC, "var", $var, $$vars{$var} ); + my $tag = $this->genBasicTag( $DOC, "var", $var, $$vars{$var} ); $VARS->appendChild($tag); } @@ -310,4 +313,59 @@ return $str; } + +=head2 C<toXML> + +This returns a string that contains an XML representation for this node. +A way to export this node. + +Returns the XML string. + +=cut + +sub toXML +{ + my ($this) = @_; + my $DOC = new XML::DOM::Document(); + my $NODE; + my $enode = $this->get_node; + my $exportFields = $enode->getNodeKeys(1); + my $tag; + my @fields; + my @rawFields; + + push @rawFields, keys %$exportFields; + + # This is used to determine if our parser can read in a particular + # export. If the parser is upgraded/modified, this should be bumped + # so that older versions of this code will know that it may have + # problems reading in XML that generated by a newer version. + my $XMLVERSION = "0.5"; + + $NODE = new XML::DOM::Element( $DOC, "NODE" ); + + $NODE->setAttribute( "export_version", $XMLVERSION ); + $NODE->setAttribute( "nodetype", $$enode{type}{title} ); + $NODE->setAttribute( "title", $$enode{title} ); + + # Sort them so that the exported XML has some order to it. + @fields = sort { $a cmp $b } @rawFields; + + foreach my $field (@fields) + { + $NODE->appendChild( new XML::DOM::Text( $DOC, "\n " ) ); + + $tag = $this->fieldToXML( $DOC, $field, " " ); + $NODE->appendChild($tag); + } + + $NODE->appendChild( new XML::DOM::Text( $DOC, "\n" ) ); + + $DOC->appendChild($NODE); + + # Return the structure as a string + return $DOC->toString(); +} + + 1; Modified: trunk/ebase/lib/Everything/XML/Test/Node.pm =================================================================== --- trunk/ebase/lib/Everything/XML/Test/Node.pm 2007-01-03 19:48:10 UTC (rev 934) +++ trunk/ebase/lib/Everything/XML/Test/Node.pm 2007-01-03 19:48:46 UTC (rev 935) @@ -78,7 +78,7 @@ my @tags; *Everything::XML::Node::genBasicTag = sub { - push @tags, join( ' ', @_[ 1 .. 3 ] ); + push @tags, join( ' ', @_[ 2 .. 4 ] ); }; $mock->set_always( getVars => { a => 1, b => 1, c => 1 } ) @@ -290,4 +290,43 @@ ); } +sub test_to_xml : Test(4) { + my $self = shift; + can_ok( $self->{class}, 'toXML' ) || return; + my $instance = $self->{instance}; + my $mock = Test::MockObject->new; + + $instance->set_node($mock); + + my @fieldtoxml_args = (); + no strict 'refs'; + local *{ $self->{class} . '::fieldToXML'}; + *{ $self->{class} . '::fieldToXML'} = + sub { + push @fieldtoxml_args, [@_]; + return 'a tag'; + }; + use strict 'refs'; + + $mock->set_always(getNodeKeys => { key1 => 'value1', key2 => 'value2'} ); + $mock->fake_module('XML::DOM::Document'); + $mock->fake_module('XML::DOM::Text'); + $mock->fake_new('XML::DOM::Document'); + $mock->fake_new('XML::DOM::Text'); + $mock->fake_new('XML::DOM::Element'); + $mock->fake_new('XML::DOM::Element'); + + $mock->set_true('-setAttribute', '-appendChild'); + $mock->set_always('toString', 'a string of xml'); + + is ($instance->toXML, 'a string of xml', '...should return XML.'); + + my ($method, $args) = $mock->next_call( ); + + is($method, 'getNodeKeys', '...should get exportable keys from node object.'); + + is_deeply ( $fieldtoxml_args[0], [$instance, $mock, 'key1', ' '], '...calls fieldToXML with arguments.'); + +} + 1; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2007-03-18 12:35:46
|
Revision: 939 http://svn.sourceforge.net/everydevel/?rev=939&view=rev Author: paul_the_nomad Date: 2007-03-16 17:26:50 -0700 (Fri, 16 Mar 2007) Log Message: ----------- FIX: using DBI::fetchrow_array, instead of DBI::fetch. fetch is returning an array rather than a list. Modified Paths: -------------- trunk/ebase/lib/Everything/DB/Test/sqlite.pm trunk/ebase/lib/Everything/DB/sqlite.pm trunk/ebase/lib/Everything/DB.pm trunk/ebase/lib/Everything/Test/DB.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:945 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 + 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:946 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/lib/Everything/DB/Test/sqlite.pm =================================================================== --- trunk/ebase/lib/Everything/DB/Test/sqlite.pm 2007-03-17 00:26:21 UTC (rev 938) +++ trunk/ebase/lib/Everything/DB/Test/sqlite.pm 2007-03-17 00:26:50 UTC (rev 939) @@ -119,7 +119,7 @@ my $self = shift; can_ok( $self->{class}, 'tableExists' ); - $self->{instance}->{dbh}->set_true( 'fetch')->clear; + $self->{instance}->{dbh}->set_true( 'fetchrow_array')->clear; my $result = $self->{instance}->tableExists('target'); my ( $method, $args ) = $self->{instance}->{dbh}->next_call(); @@ -133,9 +133,9 @@ ok( $result, '... returns true if it exists.' ); - is( $self->{instance}->{dbh}->call_pos(-1), 'fetch', '... calls fetch.' ); + is( $self->{instance}->{dbh}->call_pos(-1), 'fetchrow_array', '... calls fetches a list.' ); - $self->{instance}->{dbh}->set_false('fetch'); + $self->{instance}->{dbh}->set_false('fetchrow_array'); ok( !$self->{instance}->tableExists('target'), '... returning false if table name is not found' @@ -162,7 +162,7 @@ $self->{instance}->{dbh}->clear(); ## set fetch so that tableExists returns the appropriate value - $self->{instance}->{dbh}->set_true('fetch'); + $self->{instance}->{dbh}->set_true('fetchrow_array'); my $result = $self->{instance}->createNodeTable('proserpina'); my ( $method, $args ) = $self->{instance}->{dbh}->next_call(); @@ -177,7 +177,7 @@ $self->{instance}->{dbh}->clear(); # for the benefit of tableExists - $self->{instance}->{dbh}->set_false('fetch'); + $self->{instance}->{dbh}->set_false('fetchrow_array'); $result = $self->{instance}->createNodeTable('euphrosyne'); ( $method, $args ) = $self->{instance}->{dbh}->next_call; is( $method, 'prepare', '... calls tableExists' ); @@ -196,14 +196,14 @@ can_ok( $self->{class}, 'createGroupTable' ); $self->{instance}->{dbh}->clear(); - $self->{instance}->{dbh}->set_true('fetch'); + $self->{instance}->{dbh}->set_true('fetchrow_array'); my $result = $self->{instance}->createGroupTable('proserpina'); my ( $method, $args ) = $self->{instance}->{dbh}->next_call(); is( $method, 'prepare', 'Attempt to amend an existing table' ); is( $result, -1, '... returning -1 if so' ); - $self->{instance}->{dbh}->set_false('fetch'); + $self->{instance}->{dbh}->set_false('fetchrow_array'); $self->{instance}->{dbh}->clear(); $result = $self->{instance}->createGroupTable('elbat'); ( $method, $args ) = $self->{instance}->{dbh}->next_call(4); @@ -399,7 +399,7 @@ sub test_drop_node_table : Test(+0) { my ($self) = @_; - $self->{instance}->{dbh}->set_series( 'fetch', 0, 1 ); + $self->{instance}->{dbh}->set_series( 'fetchrow_array', 0, 1 ); $self->SUPER; } Modified: trunk/ebase/lib/Everything/DB/sqlite.pm =================================================================== --- trunk/ebase/lib/Everything/DB/sqlite.pm 2007-03-17 00:26:21 UTC (rev 938) +++ trunk/ebase/lib/Everything/DB/sqlite.pm 2007-03-17 00:26:50 UTC (rev 939) @@ -127,7 +127,8 @@ $sth->execute( $tableName ); - my ($result) = $sth->fetch(); + my ($result) = $sth->fetchrow_array(); + return $result; } Modified: trunk/ebase/lib/Everything/DB.pm =================================================================== --- trunk/ebase/lib/Everything/DB.pm 2007-03-17 00:26:21 UTC (rev 938) +++ trunk/ebase/lib/Everything/DB.pm 2007-03-17 00:26:50 UTC (rev 939) @@ -1117,6 +1117,7 @@ my ($self, $fh) = @_; my $sql = ''; foreach (<$fh>) { + next if /^#/; next if /^\//; next if /^\s*--/; next if /^\s*$/; Modified: trunk/ebase/lib/Everything/Test/DB.pm =================================================================== --- trunk/ebase/lib/Everything/Test/DB.pm 2007-03-17 00:26:21 UTC (rev 938) +++ trunk/ebase/lib/Everything/Test/DB.pm 2007-03-17 00:26:50 UTC (rev 939) @@ -93,11 +93,7 @@ $self->{instance}->{dbh}->set_always( 'prepare', $self->{instance}->{dbh}); $self->{instance}->{dbh}->set_always( 'execute', $self->{instance}->{dbh}); $self->{instance}->{dbh}->mock( 'fetchrow', sub { qw/a list/ } ); - { - my @a = @lists; - $self->{instance}->{dbh}->mock( 'fetchrow_array', - sub { return unless my $b = shift @a; return @$b } ); - } + $self->{instance}->{dbh}->set_true('finish', 'do'); } @@ -263,6 +259,12 @@ $self->{instance}->{dbh}->clear; $self->add_expected_sql('SELECT title FROM node WHERE type_nodetype=1 ') unless $self->isset_expected_sql; + { + my @a = @lists; + $self->{instance}->{dbh}->mock( 'fetchrow_array', + sub { return unless my $b = shift @a; return @$b } ); + } + my @result = $self->{instance}->fetch_all_nodetype_names; my ($method, $args) = $self->{instance}->{dbh}->next_call; is( This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2007-03-18 12:36:25
|
Revision: 942 http://svn.sourceforge.net/everydevel/?rev=942&view=rev Author: paul_the_nomad Date: 2007-03-16 17:28:00 -0700 (Fri, 16 Mar 2007) Log Message: ----------- Fixes for SQL LIMIT syntax. Quoting of table names to allow case sensitive field names. Changed "lastValue" select on pg's sequence rather than DBI::last_insert_id. Plus other sundry fixes. Modified Paths: -------------- trunk/ebase/lib/Everything/DB/Pg.pm trunk/ebase/lib/Everything/DB/Test/Pg.pm trunk/ebase/t/DB/Pg.t Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:948 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 + 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:949 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/lib/Everything/DB/Pg.pm =================================================================== --- trunk/ebase/lib/Everything/DB/Pg.pm 2007-03-17 00:27:32 UTC (rev 941) +++ trunk/ebase/lib/Everything/DB/Pg.pm 2007-03-17 00:28:00 UTC (rev 942) @@ -384,7 +384,7 @@ $offset ||= 0; - return "LIMIT $limit, $offset"; + return "LIMIT $limit OFFSET $offset"; } sub genTableName @@ -394,4 +394,39 @@ return '"' . $table . '"'; } + +sub lastValue +{ + my ( $this, $table, $field ) = @_; + + return $this->getDatabaseHandle()->selectrow_array("SELECT currval('${table}_${field}_seq')"); +} + +sub list_tables { + + my ($this) = @_; + my $sth = $this->{dbh}->prepare("select c.relname FROM pg_catalog.pg_class c LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace WHERE c.relkind IN ('r','') AND n.nspname NOT IN ('pg_catalog', 'pg_toast') AND pg_catalog.pg_table_is_visible(c.oid)"); + + $sth->execute(); + + my @tables; + while ( my ($table) = $sth->fetchrow() ) + { + push @tables, $table; + } + + return @tables; +} + +sub now { return 'now()' } + +sub _quoteData { + + my $self = shift; + my ($names, $values, $bound) = $self->SUPER( @_ ); + my @quoted_names = map { '"' . $_ .'"' } @$names; + return \@quoted_names, $values, $bound; + +} + 1; Modified: trunk/ebase/lib/Everything/DB/Test/Pg.pm =================================================================== --- trunk/ebase/lib/Everything/DB/Test/Pg.pm 2007-03-17 00:27:32 UTC (rev 941) +++ trunk/ebase/lib/Everything/DB/Test/Pg.pm 2007-03-17 00:28:00 UTC (rev 942) @@ -148,16 +148,6 @@ $self->SUPER; } -sub test_get_node_cursor : Test(+0) { - my $self = shift; - - $self->add_expected_sql( -q|SELECT fieldname FROM "node" LEFT JOIN "lions" ON node_id=lions_id LEFT JOIN "serpents" ON node_id=serpents_id WHERE foo='bar' AND type_nodetype=8888 ORDER BY title LIMIT 1, 2|, - ); - - $self->SUPER; -} - sub test_table_exists : Test(6) { my $self = shift; @@ -433,15 +423,7 @@ $self->SUPER; } -sub test_select_node_where : Test(+0) { - my $self = shift; - $self->add_expected_sql( -q|SELECT node_id FROM "node" LEFT JOIN "sylph" ON node_id=sylph_id LEFT JOIN "dryad" ON node_id=dryad_id WHERE medusa='arachne' AND type_nodetype=8888 ORDER BY title LIMIT 1, 2| - ); - $self->SUPER; -} - sub test_sql_delete : Test(+0) { my $self = shift; my $value = 'a value'; @@ -468,7 +450,7 @@ my $self = shift; $self->add_expected_sql( - qr/INSERT INTO "atable" \((?:one|foo), (?:one|foo)\) VALUES\(\?, \?\)/); + qr/INSERT INTO "atable" \((?:"one"|"foo"), (?:"one"|"foo")\) VALUES\(\?, \?\)/); $self->SUPER; } @@ -511,7 +493,7 @@ my $self = shift; $self->add_expected_sql( - qr/UPDATE "atable" SET foo = \?\s+WHERE title = \?/ms); + qr/UPDATE "atable" SET "foo" = \?\s+WHERE title = \?/ms); $self->SUPER; } @@ -565,9 +547,9 @@ can_ok( $self->{class}, 'genLimitString' ); is( $self->{class}->genLimitString( 10, 20 ), - 'LIMIT 20, 10', 'genLimitString() should return a valid limit' ); + 'LIMIT 20 OFFSET 10', 'genLimitString() should return a valid limit' ); is( $self->{class}->genLimitString( undef, 20 ), - 'LIMIT 20, 0', '... defaulting to an offset of zero' ); + 'LIMIT 20 OFFSET 0', '... defaulting to an offset of zero' ); ## opposite from mysql :) } @@ -587,15 +569,88 @@ } -sub test_list_tables : Test(0) { - local $TODO = "Unimplemented"; +sub test_get_node_cursor : Test(+0) { + my $self = shift; + $self->add_expected_sql( q|SELECT fieldname FROM "node" LEFT JOIN "lions" ON node_id=lions_id LEFT JOIN "serpents" ON node_id=serpents_id WHERE foo='bar' AND type_nodetype=8888 ORDER BY title LIMIT 1 OFFSET 2|); + $self->SUPER; } -sub test_now : Test(0) { - local $TODO = "Unimplemented"; +sub test_select_node_where : Test(+0) { + my $self = shift; + $self->add_expected_sql( q|SELECT node_id FROM "node" LEFT JOIN "sylph" ON node_id=sylph_id LEFT JOIN "dryad" ON node_id=dryad_id WHERE medusa='arachne' AND type_nodetype=8888 ORDER BY title LIMIT 1 OFFSET 2|); + $self->SUPER; + } +sub test_list_tables : Test(2) { + my $self = shift; + can_ok( $self->{class}, 'list_tables' ) || return; + my @list = (qw/auxo charis hegemone phaenna pasithea/); + my @expected = @list; + $self->{instance}->{dbh}->mock( + 'fetchrow', + sub { + my $r = shift @list; + return () unless $r; + return ($r); + } + ); + + is_deeply( [ $self->{instance}->list_tables ], + \@expected, '...returns all the tables in the DB.' ); + +} + +sub test_now : Test(2) { + my $self = shift; + can_ok( $self->{class}, 'now' ) || return; + is( $self->{instance}->now, + 'now()', + '... should return the DB function that returns current time/date' ); +} + + +sub test_quote_data : Test(6) { + my $self = shift; + my $data = { foo => ' bar', good => 'day', -to => 'you' }; + my $bound = { '"foo"' => '?', '"good"' => '?', '"to"' => 'you' }; + my $value = { '"foo"' => ' bar', '"good"' => 'day', -to => undef }; + my @rv = $self->{instance}->_quoteData($data); + my $index = 0; + foreach ( 0 .. $#{ $rv[0] } ) { + my $name = $rv[0]->[$_]; + + #bound + is( $rv[1]->[$_], $$bound{ $name }, + '_quoteData must correctly return the bound variable' ); + + #value + is( $rv[2]->[$_], $$value{$name}, + '_quoteData correctly returns the value' ); + + } + +} + +sub test_last_value : Test(3) { + my $self = shift; + + ## This finds the last insert id. In theory it is supposed to just + ## call last_insert_id on the database handle. In practice, that + ## didn't work, so we have to examine the relevant pg sequence. + + $self->{instance}->{dbh}->set_always( selectrow_array => 555 ); + is( $self->{instance}->lastValue('table', 'field'), + 555, 'lastValue should return the last insert id' ); + + my ($method, $args) = $self->{instance}->{dbh}->next_call; + + is( $method, 'selectrow_array', '...with a select call.'); + is( $args->[1], "SELECT currval('table_field_seq')", '...with the currval call.'); + +} + sub test_timediff : Test(0) { local $TODO = "Unimplemented"; } Modified: trunk/ebase/t/DB/Pg.t =================================================================== --- trunk/ebase/t/DB/Pg.t 2007-03-17 00:27:32 UTC (rev 941) +++ trunk/ebase/t/DB/Pg.t 2007-03-17 00:28:00 UTC (rev 942) @@ -1,5 +1,5 @@ #! perl use Everything::DB::Test::Pg; -Test::Class->runtests; +Everything::DB::Test::Pg->runtests; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2007-03-18 13:30:31
|
Revision: 938 http://svn.sourceforge.net/everydevel/?rev=938&view=rev Author: paul_the_nomad Date: 2007-03-16 17:26:21 -0700 (Fri, 16 Mar 2007) Log Message: ----------- Add parse_sql_file and tests. A utility method for Nodeball.pm which will go as soon as Nodeballs have a different format. Modified Paths: -------------- trunk/ebase/lib/Everything/DB.pm trunk/ebase/lib/Everything/Test/DB.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:944 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 + 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:945 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/lib/Everything/DB.pm =================================================================== --- trunk/ebase/lib/Everything/DB.pm 2007-03-17 00:25:59 UTC (rev 937) +++ trunk/ebase/lib/Everything/DB.pm 2007-03-17 00:26:21 UTC (rev 938) @@ -1092,4 +1092,39 @@ # override this to fix odd column names sub fix_node_keys {} + +=head2 C<parse_sql_file> + +This is a utility method for Nodeball.pm. It takes an open filehandle +that should be open on a file of some raw sql perhaps dumped from a +database. The method, strips out comments and blank lines and splits the string +into seperate sql statements that can then be passed individually to +DBI.pm. + +=over 4 + +=item * $fh + +Takes an open filehandle. + +=back + +Returns a list of strings, that are SQL statements. + +=cut + +sub parse_sql_file { + my ($self, $fh) = @_; + my $sql = ''; + foreach (<$fh>) { + next if /^\//; + next if /^\s*--/; + next if /^\s*$/; + $sql .= "$_"; + } + my @statements = split /;\s*/, $sql; + return @statements; + +} + 1; Modified: trunk/ebase/lib/Everything/Test/DB.pm =================================================================== --- trunk/ebase/lib/Everything/Test/DB.pm 2007-03-17 00:25:59 UTC (rev 937) +++ trunk/ebase/lib/Everything/Test/DB.pm 2007-03-17 00:26:21 UTC (rev 938) @@ -808,4 +808,74 @@ ['node'], '... but adding node if addNode flag is true' ); } +sub test_parse_sql_file :Test(2){ + my $self = shift; + my $instance = $self->{instance}; + use File::Temp qw/tempfile/; + my $fh = tempfile(UNLINK => 1); + + my $sql = <<SQL; +BEGIN TRANSACTION; + + +-- +-- Table: mail +-- +DROP TABLE IF EXISTS mail; +CREATE TABLE mail ( +-- Comments: +-- Created by SQL::Translator::Producer::PostgreSQL +-- Created on Mon Jun 14 12:06:35 2004 +-- Table: mail +-- + + mail_id INTEGER PRIMARY KEY NOT NULL DEFAULT '0', + from_address char(80) NOT NULL DEFAULT '' +); + + +-- +-- Table: image +-- +DROP TABLE IF EXISTS image; +CREATE TABLE image ( +-- Comments: +-- Created by SQL::Translator::Producer::PostgreSQL +-- Created on Mon Jun 14 12:06:09 2004 +-- Table: image +-- + + image_id INTEGER PRIMARY KEY NOT NULL, + src varchar(255), + alt varchar(255), + thumbsrc varchar(255), + description text +); + +SQL + +my @expected= ('BEGIN TRANSACTION', +'DROP TABLE IF EXISTS mail', +q{CREATE TABLE mail ( + mail_id INTEGER PRIMARY KEY NOT NULL DEFAULT '0', + from_address char(80) NOT NULL DEFAULT '' +)}, +'DROP TABLE IF EXISTS image', +'CREATE TABLE image ( + image_id INTEGER PRIMARY KEY NOT NULL, + src varchar(255), + alt varchar(255), + thumbsrc varchar(255), + description text +)'); + + +print $fh $sql; +$fh->seek(0,0); +ok(my @rv = $instance->parse_sql_file($fh), '...should parse OK.'); +is_deeply(\@rv, \@expected, '...splits the sql into manageable portions.'); + + +} + 1; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2007-03-18 13:30:50
|
Revision: 940 http://svn.sourceforge.net/everydevel/?rev=940&view=rev Author: paul_the_nomad Date: 2007-03-16 17:27:13 -0700 (Fri, 16 Mar 2007) Log Message: ----------- XML::Node single node xml parsing to extract node data and tests. Modified Paths: -------------- trunk/ebase/lib/Everything/XML/Node.pm trunk/ebase/lib/Everything/XML/Test/Node.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:946 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 + 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:947 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/lib/Everything/XML/Node.pm =================================================================== --- trunk/ebase/lib/Everything/XML/Node.pm 2007-03-17 00:26:50 UTC (rev 939) +++ trunk/ebase/lib/Everything/XML/Node.pm 2007-03-17 00:27:13 UTC (rev 940) @@ -9,11 +9,42 @@ { use Object::InsideOut; + + my @title + :Field + :Standard(title) + :Arg(title); + + my @nodetype + :Field + :Standard(nodetype) + :Arg(nodetype); + + my @export_version + :Field + :Standard(export_version) + :Arg(export_version); + my @node :Field :Standard(node) :Arg(node); + my @attributes + :Field + :Standard(attributes) + :Arg(attributes); + + my @vars + :Field + :Standard(vars) + :Arg(vars); + + my @group_members + :Field + :Standard(group_members) + :Arg(group_members); + my @nodebase :Field :Standard(nodebase) @@ -21,6 +52,9 @@ } +use XML::DOM; +use strict; +use warnings; =head2 C<fieldToXML_vars> @@ -368,4 +402,190 @@ } +sub parse_xml { + my ( $self, $xml ) = @_; + my $XMLPARSER = XML::DOM::Parser->new( + ErrorContext => 2, + ProtocolEncoding => 'ISO-8859-1' + ); + + my $doc = $XMLPARSER->parse("<everything>\n$xml\n</everything>"); + + my @nodes = $doc->getElementsByTagName("NODE"); + + foreach my $node (@nodes) { + + $self->set_title( $node->getAttribute("title") ); + $self->set_nodetype( $node->getAttribute("nodetype") ); + $self->set_export_version( $node->getAttribute("export_version")); + + my @list = $node->getElementsByTagName("field"); + + my @fields; + + foreach my $field ( @list ) { + + my $atts = $field->getAttributes; # returns a NamedNodeMap + my $name = $atts->getNamedItem('name')->getValue; + my $type = $atts->getNamedItem('type')->getValue; + my $type_nodetype = $atts->getNamedItem('type_nodetype'); + $type_nodetype = $type_nodetype->getValue if $type_nodetype; + + + ## should be only one childNode that is a text node + my @contents = $field->getChildNodes; + + my $text; + $text .= $_->getData foreach @contents; + + my $node_attribute = Everything::XML::Node::Attribute->new; + $node_attribute->set_name( $name ); + $node_attribute->set_type( $type ); + $node_attribute->set_type_nodetype( $type_nodetype ) if $type_nodetype; + $node_attribute->set_content( $text ); + + push @fields, $node_attribute; + } + + $self->set_attributes( \@fields ); + + + @list = $node->getElementsByTagName("var"); + + my @vars; + + foreach my $var ( @list ) { + + my $atts = $var->getAttributes; # returns a NamedNodeMap + my $name = $atts->getNamedItem('name')->getValue; + my $type = $atts->getNamedItem('type')->getValue; + my $type_nodetype = $atts->getNamedItem('type_nodetype'); + $type_nodetype = $type_nodetype->getValue if $type_nodetype; + + + ## should be only one childNode that is a text node + my @contents = $var->getChildNodes; + + my $text; + $text .= $_->getData foreach @contents; + + my $node_vars = Everything::XML::Node::Attribute->new; + $node_vars->set_name( $name ); + $node_vars->set_type( $type ); + $node_vars->set_type_nodetype( $type_nodetype ) if $type_nodetype; + $node_vars->set_content( $text ); + push @vars, $node_vars; + } + + $self->set_vars( \@vars ); + + + @list = $node->getElementsByTagName("member"); + + my @members; + + foreach my $member ( @list ) { + + my $atts = $member->getAttributes; # returns a NamedNodeMap + my $name = $atts->getNamedItem('name')->getValue; + my $type = $atts->getNamedItem('type')->getValue; + my $type_nodetype = $atts->getNamedItem('type_nodetype'); + $type_nodetype = $type_nodetype->getValue if $type_nodetype; + + + ## should be only one childNode that is a text node + my @contents = $member->getChildNodes; + + my $text; + $text .= $_->getData foreach @contents; + + my $group_member = Everything::XML::Node::Attribute->new; + + + $group_member->set_name( $text ); + $group_member->set_type( $type ); + $group_member->set_type_nodetype( $type_nodetype ) if $type_nodetype; + + push @members, $group_member; + } + + $self->set_group_members( \@members ); + + } + return $self; + +} + +package Everything::XML::Node::Attribute; + +{ + use Object::InsideOut; + + my @name + :Field + :Standard(name); + + my @content + :Field + :Standard(content); + + my @type_nodetype + :Field + :Standard(type_nodetype); + + my @type + :Field + :Standard(type); + +} + + +=head2 C<parse_xml> + +This method takes an XML string representing one node. It returns the instance itself. + +Onced parsed, the node attributes can be retrieved thusly: + +=over 8 + +=item * get_title + +=item * get_nodetype + +=item * get_exportversion + +=back + +The attribtutes, vars and group members can be retrieved like this: + +=over 8 + +=item * get_attributes + +=item * get_vars + +=item * get_group_members + +=back + +Each of these returns an array ref of Everything::XML::Node::Attribute objects. Everything::XML::Node::Attribute objects support the following methods: + + +=over 8 + +=item * get_name + +=item * get_type + +=item * get_type_nodetype + +=item * get_content + +=back + +That way we can parse XML files purporting to be nodes and extract the information therein. + +=cut + + 1; Modified: trunk/ebase/lib/Everything/XML/Test/Node.pm =================================================================== --- trunk/ebase/lib/Everything/XML/Test/Node.pm 2007-03-17 00:26:50 UTC (rev 939) +++ trunk/ebase/lib/Everything/XML/Test/Node.pm 2007-03-17 00:27:13 UTC (rev 940) @@ -290,6 +290,53 @@ ); } +sub test_a_parse_xml : Test( 12 ) { + my $self = shift; + can_ok( $self->{class}, 'parse_xml' ) || return; + my $instance = $self->{instance}; + my $mock = Test::MockObject->new; + + my $xml = '<NODE title="a test node" nodetype="supertype" export_version="1000"><field name="a field name" type="literal_value">blah</field><vars><var name="default_theme" type="noderef" type_nodetype="theme,nodetype">default theme</var></vars><group><member name="group_node" type="noderef" type_nodetype="restricted_superdoc,nodetype">Everything settings</member></group></NODE>'; + + ok( $instance->parse_xml($xml), '...parses the XML'); + my $fields = $instance->get_attributes; + my $vars = $instance->get_vars; + my $group_members = $instance->get_group_members; + + is ($instance->get_title, 'a test node', '...with a node title.'); + is ($instance->get_nodetype, 'supertype', '...with a node type.'); + is ($instance->get_export_version, 1000, '...with an export version.'); + + foreach (@$fields) { + my $field_name = $_->get_name; + my $field_content = $_->get_content; + my $field_type = $_->get_type; + my $field_type_nodetype = $_->get_type_nodetype; + is($field_name, 'a field name', '...one field with field name.'); + is ($field_content, 'blah', '...with the correct content'); + } + + foreach (@$vars) { + my $var_name = $_->get_name; + my $var_content = $_->get_content; + my $var_type = $_->get_type; + my $var_type_nodetype = $_->get_type_nodetype; + is($var_name, 'default_theme', '...one field with field name.'); + is ($var_content, 'default theme', '...with the correct content'); + } + + + foreach (@$group_members) { + my $member_name = $_->get_name; + my $member_type = $_->get_type; + my $member_type_nodetype = $_->get_type_nodetype; + is($member_name, 'Everything settings', '...one field with field name.'); + is ($member_type_nodetype, 'restricted_superdoc,nodetype', '...with the correct content'); + is($member_type, 'noderef', '...groups nodes are always noderefs.'); + } + +} + sub test_to_xml : Test(4) { my $self = shift; can_ok( $self->{class}, 'toXML' ) || return; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pau...@us...> - 2007-03-18 13:33:26
|
Revision: 941 http://svn.sourceforge.net/everydevel/?rev=941&view=rev Author: paul_the_nomad Date: 2007-03-16 17:27:32 -0700 (Fri, 16 Mar 2007) Log Message: ----------- FIX: xml parser test for whether data is 'defined' rather than whether it is true or not. 0 and '' (i.e.) zero and the empty string are valid data even though they are both 'not true'. The parsers must always take this into account. Modified Paths: -------------- trunk/ebase/lib/Everything/XML.pm Property Changed: ---------------- trunk/ebase/ Property changes on: trunk/ebase ___________________________________________________________________ Name: svk:merge - 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:947 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 + 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:948 a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930 Modified: trunk/ebase/lib/Everything/XML.pm =================================================================== --- trunk/ebase/lib/Everything/XML.pm 2007-03-17 00:27:13 UTC (rev 940) +++ trunk/ebase/lib/Everything/XML.pm 2007-03-17 00:27:32 UTC (rev 941) @@ -546,7 +546,7 @@ my $contents; $contents = $first->toString() if $first; - $contents ||= ''; + $contents = '' if not defined $contents; $contents = unMakeXmlSafe($contents); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |