@@ -1,8 +1,81 @@
Revision history for Perl extension DBIx::SearchBuilder.
+1.33 Thu Sep 22 14:27:46 EDT 2005
+
+* Better SQL statement logging from alex
+
+
+1.32 Thu Sep 1 06:52:42 EDT 2005
+
+* DBD::SQLite is necessary for the test suite to run correctl
+
+1.31 Fri Jul 29 12:47:25 EDT 2005
+
+* Updated MANIFEST to fix a build issue -
+ Thanks to Andy Lester and David Glasser
+
+1.30 Thu Jul 28 10:17:27 EDT 2005
+
+* Removed {{{ and }}} fold markers. Patch from Ruslan
+
+1.30_03 Thu Jun 9 01:35:49 EDT 2005
+* Significant new tests from Ruslan Zakirov and Dave Glasser
+
+* You no longer need to explicitly bless a DBIx::SearchBuilder::Handle subclass
+
+* Start of a major overhaul of the subclass API for DBIx::SearchBuilder::Record objects.
+ A new "schema" method will define the data in _ClassAccessible and also generate database
+ schema using DBIx::DBSchema.
+
+Fixes from Ruslan:
+
+ * for numeric types, make the empty check be "null or 0", not "null or ''"
+ * New search tests from ruslan
+ * added an init_data method to t/utils.pl
+ * CleanSlate doesnt init show_rows
+ * CleanSlate doesnt clean _{open|close}_parens
+ * get rid of stupid ifs in CleanSlate
+ * get rid of evals in _DoSearch and _DoCount, use Handle methods to control DBI error handling
+ * rewrite LoadByPrimaryKeys args handling to consistent with other Load* methods
+ * report error when PK filed is missing in LoadByPrimaryKeys
+ * fix warning in __Set methods when newvalue is undef
+ * small code cleanups
+ * test coverage grows from 75.2% to 84.7% for Record.pm
+
+
+1.30_02 Sun May 22 15:21:19 EDT 2005
+
+ - Lots of patches from Ruslan:
+
+ First and main change is using of `goto &$AUTOLOAD` syntax, that helps
+ avoid code duplication and hides AUTOLOAD sub from stack trace. I think
+ this also would help implement CompileAllAutoSubs method easier.
+
+ - It's also one of the steps to better tests coverage.
+
+ - Test coverage for Record.pm grows from 66% to 75.2%.
+
+ - _LoadFromSQL never reported error when PK fields are missed. Fixed.
+
+ - fetchrow_hashref dies only when RaiseErrors is true, because we can
+ control this from Handle obj so we should die according to
+ $Handle->RaiseErrors property. Fixed.
+ - When RaiseErrors is "false" then fetchrow_hashref returns undef and we
+ should check $sth->err(see `perldoc DBI`). Fixed.
+
+ - After call to fetchrow we should clean "fetched" internal hash and fill
+ it only when we return successful result. Fixed.
+
+ - If SimpleQuery fails, _LoadFromSQL method doesn't return any error
+ message. Fixed.
+
+1.30_01 Mon May 16 21:37:03 BST 2005
+
+ - Patches from Ruslan to switch to using 'capitalization.pm' for our regular_case subroutine aliases
+
1.27 Sun May 8 22:49:30 EDT 2005
- - Added supoprt for functions containing "?" to represent the parameter
+ - Added supoprt for functions containing "?" to represent the parameter
in ->Column()
- Added better support for functional columns in search listings and
group by clauses
@@ -38,7 +111,7 @@ Revision history for Perl extension DBIx::SearchBuilder.
1.19 Sat Jan 8 18:22:59 EST 2005
- - Performing a search multiple times could result in multiple copies of
+ - Performing a search multiple times could result in multiple copies of
records in a collection. Uncovered thanks to Kevin Chen and Alex Vandiver.
1.18
@@ -55,8 +128,8 @@ Revision history for Perl extension DBIx::SearchBuilder.
- More record tests from Ruz
1.16 Thu Dec 9 23:49:39 EST 2004
- - Fixed a bug in D::SB::R::Cachable that could cause it to load the wrong row from the cache if you were loading
- by alternate keys and had since changed one of the attributes of a previous row. This was unmasked by a
+ - Fixed a bug in D::SB::R::Cachable that could cause it to load the wrong row from the cache if you were loading
+ by alternate keys and had since changed one of the attributes of a previous row. This was unmasked by a
bug that Ruslan Zakirov found in RT 3.3's custom field handling
@@ -76,9 +149,9 @@ Revision history for Perl extension DBIx::SearchBuilder.
- SearchBuilder now truncates strings before inserting them into character
types in the database as mysql generally does. Additionally, it truncates
things at utf8 character boundaries...as mysql does not.
- - Fix for an undefined record cache warning on load from Autrijus Tang
+ - Fix for an undefined record cache warning on load from Autrijus Tang
- Major documentation cleanups --Simon Cavalletto
- - A few tweaks to the ::Record class to eliminate the
+ - A few tweaks to the ::Record class to eliminate the
hard-coding of the name of the id column --Simon Cavalletto
1.12
@@ -88,8 +161,8 @@ Revision history for Perl extension DBIx::SearchBuilder.
1.11
- - When loading an object whose "id" has been altered, as in the case of RT's
- "Merge" functionality, the wrong object was returned by the caching layer.
+ - When loading an object whose "id" has been altered, as in the case of RT's
+ "Merge" functionality, the wrong object was returned by the caching layer.
Special casing for the "id" method was removed.
@@ -100,7 +173,7 @@ Revision history for Perl extension DBIx::SearchBuilder.
1.10_05
- - Reworked the _Accessible mechanism in DBIx::SearchBuilder::Record to
+ - Reworked the _Accessible mechanism in DBIx::SearchBuilder::Record to
remove a horribly crufty old caching mechanism that created a copy
of the accessible hash for each and every object instantiated,
sometimes quite slowly.
@@ -109,7 +182,7 @@ Revision history for Perl extension DBIx::SearchBuilder.
1.10_04 Mon Aug 30 17:33:18 EDT 2004
-A query builder fix for an issue that bit RT2:
+A query builder fix for an issue that bit RT2:
Unsatisfied dependency chain in Joins Users_2 at /usr/local/share/perl/5.8.3/DBIx/SearchBuilder/Handle.pm line 965, line 69.
@@ -132,7 +205,7 @@ Stack:
1.02_03 Thu Jul 22 13:29:17 EDT 2004
- - Additional bullet proofing for joins.
+ - Additional bullet proofing for joins.
Now we default to ALIAS1 being "main" (cubic@acronis.ru)
1.02_02 Tue Jul 20 13:06:06 EDT 2004
@@ -142,7 +215,7 @@ Stack:
1.02_01 Wed Jul 7 12:28:08 EDT 2004
- magic _Object instantiation from cubic@acronis.ru
- make SB::_Handle settable directly (cubic@acronis.ru)
- - document the above
+ - document the above
1.01 Sun Jun 27 23:35:46 EDT 2004
@@ -155,7 +228,7 @@ Stack:
1.00_05 - Force utf8 flag on when doing searches for utf8 data; this
is a workaround for DBDs that don't do it themselves.
-1.00_04 - Move Postgres specific join behaviour to the superclass so
+1.00_04 - Move Postgres specific join behaviour to the superclass so
everyone gets the benefit.
1.00_03 - Remove "AS" from table name aliases on joins, since Oracle
@@ -172,7 +245,7 @@ Stack:
Released at the YAPC::Taipei::22004 Release Party
-0.98_04 - New mysql/oracle "Join" code that allows more complex bundling of
+0.98_04 - New mysql/oracle "Join" code that allows more complex bundling of
joins from Linda and Robert
0.98_03 - New test infrastructure from Andy Lester
@@ -187,18 +260,18 @@ Stack:
0.96 - Releasing 0.96_01 as usable
0.96_01 - Fix a couple of spurious warnings in Record::Cachable
- Records loaded from multiple-record searches were never cached
+ Records loaded from multiple-record searches were never cached
correctly
0.95_03 - Allow case-insensitive loading by columns in SearchBuilder::Record
- - Record::LoadByCols now lets you specify operator and values
+ - Record::LoadByCols now lets you specify operator and values
-0.95_01
+0.95_01
- Removed historical escaping for non-ascii searche queries
0.94- - Fix for multiple handles in one app from Autrijus Tang
-0.93
+0.93
- Added ODBC database driver from Autrijus Tang
- Added the ability to sort on functions of columns from Autrijus Tang
- Improved case-insensitve searching behavior for PostgreSQL
@@ -209,7 +282,7 @@ Stack:
- Fixed a bug that caused certain types of pre-canned table aliases to fail to work on join
0.90 Aug 8, 2003
- - Disable Class::ReturnValue's stack trace feature as it interacted poorly with a stack containing lots of data
+ - Disable Class::ReturnValue's stack trace feature as it interacted poorly with a stack containing lots of data
0.89_02 July 19, 2003
- Patch from Grant DeGraw to allow ordering by multiple columns.
@@ -239,7 +312,7 @@ Stack:
- Provide support for blowing away nested transactions that aren't yet committed.
0.83_04 June 2 2003
- - Fixed how values of returned hashes are downcased.
+ - Fixed how values of returned hashes are downcased.
- Should be a minor perf improvement
0.83_03 May 30 2003
@@ -250,7 +323,7 @@ Stack:
0.83_01 May 27 2003
- Stan's DESTROY fix
- - Mathieu Arnold's patch to make function naming for
+ - Mathieu Arnold's patch to make function naming for
autoloaded functions a bit more flexible
0.82 May 19 2003
@@ -287,14 +360,14 @@ Stack:
0.76 Dec 30 2002
- Extra checking for cache misses in DBIx::SearchBuilder::Record::Cachable
- - The start of support for checking database version, so that we can do
+ - The start of support for checking database version, so that we can do
version-specific SQL
- A patch from Autrijus Tang that allows utf-8 safe searching
0.75 Dec 06 2002
- Applying a patch from Rob Spier <rspier@pobox.com> which enables
- arbitrarily complex grouping clauses. It's a hack, but we love it
- anyway....at least until SB gets redone with proper arbitrarily
+ arbitrarily complex grouping clauses. It's a hack, but we love it
+ anyway....at least until SB gets redone with proper arbitrarily
complex query generation.
0.74 Oct 11 2002
@@ -302,7 +375,7 @@ Stack:
0.73 Sep 10 2002
- More class-returnvalue ification
- - Fixed a caching bug that caused multiple copies of an object in memory to not
+ - Fixed a caching bug that caused multiple copies of an object in memory to not
be kept in sync
0.72 Aug 28 2002
@@ -326,7 +399,7 @@ Stack:
0.30 Fri May 11 14:59:17 EDT 2001
- Added DBIx::SearchBuilder::Record::Cachable from <mhat@netlag.com>
- - Changed SearchBuilder->Count to do the right thing if no
+ - Changed SearchBuilder->Count to do the right thing if no
query has been performed
- No longer specify a sort order if no sort order was specified ;)
@@ -1,12 +1,17 @@
Changes
+ex/create_tables.pl
+ex/Example/Model/Address.pm
+ex/Example/Model/Employee.pm
inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
inc/Module/Install/Base.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
Makefile.PL
MANIFEST This list of files
-SIGNATURE
META.yml
+README
+ROADMAP
SearchBuilder.pm
SearchBuilder/Handle.pm
SearchBuilder/Handle/Informix.pm
@@ -19,11 +24,19 @@ SearchBuilder/Handle/SQLite.pm
SearchBuilder/Handle/Sybase.pm
SearchBuilder/Record.pm
SearchBuilder/Record/Cachable.pm
+SearchBuilder/SchemaGenerator.pm
SearchBuilder/Union.pm
SearchBuilder/Unique.pm
-t/utils.pl
+SIGNATURE
t/00.load.t
t/01basics.t
+t/01nocap_api.t
t/01records.t
+t/01searches.t
t/02records_object.t
+t/03rebless.t
+t/10schema.t
+t/11schema_records.t
t/pod.t
+t/testmodels.pl
+t/utils.pl
@@ -1,9 +1,10 @@
name: DBIx-SearchBuilder
-version: 1.26
+version: 1.33
license: perl
distribution_type: module
build_requires:
- Test::More: 0
+ Test::More: 0.52
+ DBD::SQLite: 0
requires:
DBI: 0
Want: 0
@@ -7,8 +7,22 @@ requires('DBI');
requires('Want');
requires('Encode');
requires('Class::ReturnValue', 0.40);
-requires( 'Cache::Simple::TimedExpiry' => '0.21');
-build_requires('Test::More');
+requires('Cache::Simple::TimedExpiry' => '0.21');
+build_requires('Test::More' => 0.52);
+build_requires('DBD::SQLite');
+
+features(
+ 'Lower case API' => [
+ -default => 0,
+ 'capitalization' => '0.03',
+ ],
+ 'Schema generation' => [
+ -default => 1,
+ 'DBIx::DBSchema' => '',
+ 'Class::Accessor' => '',
+ ],
+);
+auto_install();
&Makefile->write;
&Meta->write;
@@ -0,0 +1,37 @@
+NAME
+ DBIx::SearchBuilder - Encapsulate SQL queries and rows in simple perl
+ objects
+
+DESCRIPTION
+ This module provides an object-oriented mechanism for retrieving and
+ updating data in a DBI-accesible database.
+
+INSTALLATION
+ $ perl Makefile.PL
+ $ make
+ $ make test # but see below for how to actually test against a test database
+ # make install
+
+TESTING
+ In order to test most of the features of "DBIx::SearchBuilder", you need
+ to provide "make test" with a test database. For each DBI driver that
+ you would like to test, set the environment variables "SB_TEST_FOO",
+ "SB_TEST_FOO_USER", and "SB_TEST_FOO_PASS" to a database name, database
+ username, and database password, where "FOO" is the driver name in all
+ uppercase. You can test as many drivers as you like. (The appropriate
+ "DBD::" module needs to be installed in order for the test to work.)
+ Note that the "SQLite" driver will automatically be tested if
+ "DBD::Sqlite" is installed, using a temporary file as the database. For
+ example:
+
+ SB_TEST_MYSQL=test SB_TEST_MYSQL_USER=root SB_TEST_MYSQL_PASS=foo \
+ SB_TEST_PG=test SB_TEST_PG_USER=postgres make test
+
+AUTHOR
+ Copyright (c) 2001-2005 Jesse Vincent, jesse@fsck.com.
+
+ All rights reserved.
+
+ This library is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
@@ -0,0 +1,59 @@
+Things should/could be done in 1.x releases:
+ * cover as much as possible code with tests
+ * IsLast is not consistent(see t/01records.t)
+ * LoadFromHash doesn't return any errors as other Load* methods do
+ ** it should report back missing PK fields
+ * Don't prevent DBI from die or reporting errors, now we have control
+ with RaiseErrors and PrintErrors in Handle.pm. We should just check
+ for $sth is defined and check $sth->err if fetch* methods returns undef.
+ ** partly fixed
+ * Count&CountAll:
+ ** Count should always return how much rows we can fetch with Next,
+ using pages affect this.
+ ** CountAll should always return how many records we can fetch with
+ applied conditions no matter use we pages or not to fetch it.
+ ** document differences of the methods
+ * More support for compound PKs.
+
+Known bugs:
+ * CountAll corner case:
+ * new collection
+ * CounAll returns 0
+ * Limit collection
+ * CountAll returns correct value
+ * UnLimit or apply other limit(only change must_redo_search)
+ * CountAll returns old value
+
+ Could be fixed in one line change in CountAll sub, but interfere with
+ Pages. When you call NextPage or other page walking methods
+ must_redo_search bcomes true also so CountAll after NextPage force
+ useless query.
+
+Things should be done in 2 release:
+ * switch to lover case API
+ ** patch capitalization.pm to support converting from lower case
+ to upper.
+ * Class::ReturnValue is prefered way to handle errors, should implement
+ it in all error paths.
+ * rework&review pages support, now I can't write next code:
+ while( $records->NextPage ) {
+ while( my $rec = $records->Next ) {
+ ...
+ }
+ }
+
+ * New methods: Prev, Current. Refactor collection walking:
+ ** $sb->{itemscount} can be undef, what means that we are in the begin
+ or end of the set.
+ ** Current, returns undef if $sb->{itemscount} is undef, in other case
+ returns record from array using $sb->{itemscount} as index.
+ ** IsLast and IsFirst return undef if Current is not defined, and
+ return 0 or 1 in other cases.
+ ** First and Last - work as before, return undef or object.
+ ** GotoItem supports undef as argument and returns undef or object.
+ ** Next walks forward, returns first object if Current is undef,
+ if there is no Next in set drops $sb->{itemscount} to undef and
+ returns undef.
+ ** Prev walks backward and works like Next, but if Current is undef
+ it starts from Last record.
+
@@ -14,38 +14,51 @@ not run its Makefile.PL or Build.PL.
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 82cd67dad9314c6304aecf52827635de81fd60cf Changes
-SHA1 dceebecaec0a60f15be74ac0ecd26eb6dfe7cf91 MANIFEST
-SHA1 8ffc4a3c3155957c5c4275c3a32403c6506e9c07 META.yml
-SHA1 6d660abb8f5ceb477b017d1cdbc8c73812a86eb2 Makefile.PL
-SHA1 78de43209e1343572d5dda7b7ad2204325bab471 SearchBuilder.pm
-SHA1 799f8da0756e572d3a1397a5ecbf363a482f1ab9 SearchBuilder/Handle.pm
-SHA1 0103d897704a95032b32363dc65ea4f0d8f5965d SearchBuilder/Handle/Informix.pm
+SHA1 b99db3fa10d5c7616968319db1bd03f1d16b632d Changes
+SHA1 e2ecbebae35087c74c256cf60871783963108dde MANIFEST
+SHA1 68591cf5f61a2be9288cedf25cc69edcf8284317 META.yml
+SHA1 ee67bd8159b64f5020f5ddd82cc88375c3716e06 Makefile.PL
+SHA1 d7a41642c368f2a587587e09f9e815d434feebff README
+SHA1 5a53d12d5cccd94845a6a7cc105cd9be34e20f1c ROADMAP
+SHA1 f09f56a6b597995f47a3193d37bf09a5cd9c0fb3 SearchBuilder.pm
+SHA1 dd33a037b62d7d6d0263aa5beb464199df7174f6 SearchBuilder/Handle.pm
+SHA1 3ae0584e86c7573b6bfda4d025193c970ba30b40 SearchBuilder/Handle/Informix.pm
SHA1 861cee4205d1f367af5cc68b561fd37e38c1acf0 SearchBuilder/Handle/ODBC.pm
-SHA1 6f798ff065f28239767230fcd8c9330dae4eafa7 SearchBuilder/Handle/Oracle.pm
-SHA1 bd0be64d5ce723cdc6323cc8c8b2265f58a959f9 SearchBuilder/Handle/Pg.pm
-SHA1 52b3c2a83c16965ee9a8aecd4dae60ac1051a0d5 SearchBuilder/Handle/SQLite.pm
-SHA1 aec168c75ba6a33e3e5ac85cbefd2e2d7c036696 SearchBuilder/Handle/Sybase.pm
-SHA1 6399c19c7600c01f75e187facb1c01b2611b95df SearchBuilder/Handle/mysql.pm
+SHA1 50069f9fbfec254371f4c295f517fb73e1c006b2 SearchBuilder/Handle/Oracle.pm
+SHA1 cc978e63ce39bd3166e4a33f64988e0909e1bfe6 SearchBuilder/Handle/Pg.pm
+SHA1 b2efe7b5c8fe4016dcbcfb4c0617b9123fa31934 SearchBuilder/Handle/SQLite.pm
+SHA1 494edbdaf8c9ba7c36fec4809d595051594a9c47 SearchBuilder/Handle/Sybase.pm
+SHA1 7fac6d8e867781f7d2007f8cc91bb7d9eadb1bfe SearchBuilder/Handle/mysql.pm
SHA1 f4f6ea88631e6310243b6351e8df11e1ec88b261 SearchBuilder/Handle/mysqlPP.pm
-SHA1 2edb9d2e62896c79ff7270e1192a6156d550f12c SearchBuilder/Record.pm
-SHA1 4ecb1213589d62c08b3e3bb46bffbd9cda09ea10 SearchBuilder/Record/Cachable.pm
+SHA1 a628f565b460cf4060d3ef1fdb17878059eac7e5 SearchBuilder/Record.pm
+SHA1 a5201fbeca07c19669ce920a4d48e39634626c46 SearchBuilder/Record/Cachable.pm
+SHA1 a15065e472797e2bfe8149f04d3bdc58f67a7a6d SearchBuilder/SchemaGenerator.pm
SHA1 446f59a1fa8fa631c908f1fe3ea671c7178c9270 SearchBuilder/Union.pm
-SHA1 e337b5cb2776245f943a3445a2187fe80823ffd1 SearchBuilder/Unique.pm
+SHA1 1eb4e838ff1d8d927bfe177bf578df246802b03d SearchBuilder/Unique.pm
+SHA1 e7c7c7c91025072d25da78c93cefa2bc0aaf2b35 ex/Example/Model/Address.pm
+SHA1 f821661849153c21ad99393b6a3ea6720fdaf581 ex/Example/Model/Employee.pm
+SHA1 9689368197327e7b38af7f3d1f863e918ed4fa98 ex/create_tables.pl
SHA1 05d89e1fe6d49cd518b5a3e6694cc313e655fb02 inc/Module/Install.pm
+SHA1 8a9c31fdf6a65a32295c8630923988f590bbf0f6 inc/Module/Install/AutoInstall.pm
SHA1 2e300b145ee61eea9dfd71624b17b0bc9218aa4f inc/Module/Install/Base.pm
SHA1 e094fe96aef06c68d7a424818c12e52b11f1ccdd inc/Module/Install/Makefile.pm
SHA1 e448c6dc5351ef425e3f8bdbeb642409120bc3ca inc/Module/Install/Metadata.pm
SHA1 e59ea21b9407644714a5f67c7132a11916c25133 t/00.load.t
-SHA1 c59e7dce93fbfd0d942cad8fc7f723a08301da39 t/01basics.t
-SHA1 14bcc915f2138bd9e2cfc2d71a1dc81f48d1c2a9 t/01records.t
-SHA1 c6d09fe0aed0504426b40f9bd630690f7ba69e4d t/02records_object.t
+SHA1 a7ed1ee359ebe2842b354b5652a441403e802080 t/01basics.t
+SHA1 2b2dc6f72370f60e1d233f2f8c12bb87414e825c t/01nocap_api.t
+SHA1 0b41cb395ef2894ccfbb9facd46d8667af7995fc t/01records.t
+SHA1 1fbd65dc3d1e06cb46fa75dbd92eafae6e980250 t/01searches.t
+SHA1 18c721a5d0710b2e610f28eac705d8fb6e6dd8d7 t/02records_object.t
+SHA1 a1808be8dd28bd176ae0243876de36691afefefb t/03rebless.t
+SHA1 f8f5634e7dc28068722347f47d7e05d06435e22c t/10schema.t
+SHA1 56dc809450f969d0b2f624b6e11f0b7fe3d13113 t/11schema_records.t
SHA1 e9c6a5881fc60173fbc8d479c1afd2ce3b43bef1 t/pod.t
-SHA1 97cdae718319ca9e2cd6d2c0cfe2f07cda098284 t/utils.pl
+SHA1 dacb28645e8b80df7c190ddfedcdc957c3d08d75 t/testmodels.pl
+SHA1 4788496012998da32d01aef7e74d2070931290e0 t/utils.pl
-----BEGIN PGP SIGNATURE-----
-Version: GnuPG v1.2.5 (GNU/Linux)
+Version: GnuPG v1.4.1 (GNU/Linux)
-iD8DBQFCftBOEi9d9xCOQEYRAgaPAJ48HqtCHHPXOviDnywqb4KZGkpIuQCfV54K
-qtwpNKUdwewDvW5Tj6TPs9A=
-=P2YO
+iD8DBQFDMvf0Ei9d9xCOQEYRAqL0AKCxJDGbnESlu8gFHgU0gDJq9eaTUgCdHuLa
+xBpAkFKMMlEA0yw7WdqozHY=
+=1MuO
-----END PGP SIGNATURE-----
@@ -23,7 +23,6 @@ compensates for some of the idiosyncrasies of Informix.
=cut
-# {{{ sub Insert
=head2 Insert
@@ -49,7 +48,6 @@ sub Insert {
return( $self->{'id'}); #Add Succeded. return the id
}
-# }}}
=head2 CaseSensitive
@@ -62,7 +60,6 @@ sub CaseSensitive {
return(1);
}
-# }}}
=head2 BuildDSN
@@ -87,7 +84,6 @@ sub BuildDSN {
$self->{'dsn'}= $dsn;
}
-# {{{ ApplyLimits
=head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
@@ -108,7 +104,6 @@ sub ApplyLimits {
}
}
-# }}}
sub Disconnect {
my $self = shift;
@@ -121,7 +116,6 @@ sub Disconnect {
}
}
-# {{{ DistinctQuery
=head2 DistinctQuery STATEMENTREF
@@ -141,7 +135,6 @@ sub DistinctQuery {
}
-# }}}
1;
@@ -24,7 +24,6 @@ compensates for some of the idiosyncrasies of Oracle.
=cut
-# {{{ sub Connect
=head2 Connect PARAMHASH: Driver, Database, Host, User, Password
@@ -52,9 +51,7 @@ sub Connect {
return ($DBIHandle);
}
-# }}}
-# {{{ sub Insert
=head2 Insert
@@ -119,9 +116,7 @@ sub Insert {
return( $self->{'id'}); #Add Succeded. return the id
}
-# }}}
-# {{{ BuildDSN
=head2 BuildDSN PARAMHASH
@@ -158,9 +153,7 @@ sub BuildDSN {
$self->{'dsn'}= $dsn;
}
-# }}}
-# {{{ KnowsBLOBs
=head2 KnowsBLOBs
@@ -174,9 +167,7 @@ sub KnowsBLOBs {
return(undef);
}
-# }}}
-# {{{ BLOBParams
=head2 BLOBParams FIELD_NAME FIELD_TYPE
@@ -195,9 +186,7 @@ sub BLOBParams {
});
}
-# }}}
-# {{{ ApplyLimits
=head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
@@ -243,9 +232,7 @@ sub ApplyLimits {
}
}
-# }}}
-# {{{ DistinctQuery
=head2 DistinctQuery STATEMENTREF
@@ -265,10 +252,8 @@ sub DistinctQuery {
}
-# }}}
-# {{{ BinarySafeBLOBs
=head2 BinarySafeBLOBs
@@ -282,7 +267,6 @@ sub BinarySafeBLOBs {
return(undef);
}
-# }}}
1;
@@ -6,7 +6,7 @@ use strict;
use vars qw($VERSION @ISA $DBIHandle $DEBUG);
use base qw(DBIx::SearchBuilder::Handle);
-use Want qw(want);
+use Want qw(want howmany);
use strict;
@@ -26,7 +26,6 @@ compensates for some of the idiosyncrasies of Postgres.
=cut
-# {{{ sub Connect
=head2 Connect
@@ -45,9 +44,7 @@ sub Connect {
$self->AutoCommit(1);
return ($DBIHandle);
}
-# }}}
-# {{{ sub Insert
=head2 Insert
@@ -84,9 +81,7 @@ sub Insert {
return ($self->{'id'});
}
-# }}}
-# {{{ BinarySafeBLOBs
=head2 BinarySafeBLOBs
@@ -99,7 +94,6 @@ sub BinarySafeBLOBs {
return(undef);
}
-# }}}
=head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
@@ -128,7 +122,6 @@ sub ApplyLimits {
}
-# {{{ _MakeClauseCaseInsensitive
=head2 _MakeClauseCaseInsensitive FIELD OPERATOR VALUE
@@ -146,7 +139,7 @@ sub _MakeClauseCaseInsensitive {
my $value = shift;
- if ($value =~ /^\d+$/) { # we don't need to downcase numeric values
+ if ($value =~ /^['"]?\d+['"]?$/) { # we don't need to downcase numeric values
return ( $field, $operator, $value);
}
@@ -155,7 +148,7 @@ sub _MakeClauseCaseInsensitive {
return ( $field, $operator, $value );
}
elsif ( $operator =~ /=/ ) {
- if (want(4)) {
+ if (howmany() >= 4) {
return ( "LOWER($field)", $operator, $value, "LOWER(?)");
}
# RT 3.0.x and earlier don't know how to cope with a "LOWER" function
@@ -171,7 +164,6 @@ sub _MakeClauseCaseInsensitive {
}
}
-# }}}
1;
__END__
@@ -22,7 +22,6 @@ compensates for some of the idiosyncrasies of SQLite.
=cut
-# {{{ sub Insert
=head2 Insert
@@ -50,7 +49,6 @@ sub Insert {
return( $self->{'id'}); #Add Succeded. return the id
}
-# }}}
=head2 CaseSensitive
@@ -68,7 +66,6 @@ sub BinarySafeBLOBs {
return undef;
}
-# }}}
=head2 DistinctCount STATEMENTREF
@@ -87,7 +84,6 @@ sub DistinctCount {
}
-# }}}
=head2 _BuildJoins
@@ -116,7 +112,7 @@ sub _BuildJoins {
}
}
- my $join_clause = $sb->{'table'} . " main ";
+ my $join_clause = $sb->Table . " main ";
my @keys = ( keys %{ $sb->{'left_joins'} } );
my %seen;
@@ -23,7 +23,6 @@ compensates for some of the idiosyncrasies of Sybase.
=cut
-# {{{ sub Insert
=head2 Insert
@@ -60,7 +59,6 @@ sub Insert {
-# }}}
=head2 DatabaseVersion
@@ -90,7 +88,6 @@ sub CaseSensitive {
}
-# }}}
sub ApplyLimits {
@@ -118,7 +115,6 @@ sub DistinctQuery {
}
-# {{{ BinarySafeBLOBs
=head2 BinarySafeBLOBs
@@ -132,9 +128,7 @@ sub BinarySafeBLOBs {
return(undef);
}
-# }}}
-# }}}
1;
@@ -23,7 +23,6 @@ compensates for some of the idiosyncrasies of MySQL.
=cut
-# {{{ sub Insert
=head2 Insert
@@ -53,7 +52,6 @@ sub Insert {
return( $self->{'id'}); #Add Succeded. return the id
}
-# }}}
=head2 DatabaseVersion
@@ -81,7 +79,6 @@ sub CaseSensitive {
return(undef);
}
-# }}}
1;
@@ -1,7 +1,7 @@
# $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle.pm,v 1.21 2002/01/28 06:11:37 jesse Exp $
package DBIx::SearchBuilder::Handle;
use strict;
-use Carp;
+use Carp qw(croak cluck);
use DBI;
use Class::ReturnValue;
use Encode;
@@ -13,7 +13,6 @@ $TRANSDEPTH = 0;
$VERSION = '$Version$';
-# {{{ Top POD
=head1 NAME
@@ -29,6 +28,7 @@ DBIx::SearchBuilder::Handle - Perl extension which is a generic DBI handle
Host => 'hostname',
User => 'dbuser',
Password => 'dbpassword');
+ # now $handle isa DBIx::SearchBuilder::Handle::mysql
=head1 DESCRIPTION
@@ -36,9 +36,7 @@ This class provides a wrapper for DBI handles that can also perform a number of
=cut
-# }}}
-# {{{ sub new
=head2 new
@@ -56,9 +54,7 @@ sub new {
return $self;
}
-# }}}
-# {{{ sub Connect
=head2 Connect PARAMHASH: Driver, Database, Host, User, Password
@@ -69,6 +65,12 @@ You should _always_ set
DisconnectHandleOnDestroy => 1
unless you have a legacy app like RT2 or RT 3.0.{0,1,2} that depends on the broken behaviour.
+
+If you created the handle with
+ DBIx::SearchBuilder::Handle->new
+and there is a DBIx::SearchBuilder::Handle::(Driver) subclass for the driver you have chosen,
+the handle will be automatically "upgraded" into that subclass.
+
=cut
sub Connect {
@@ -85,11 +87,19 @@ sub Connect {
DisconnectHandleOnDestroy => undef,
@_);
- my $dsn = $self->DSN;
+ if( $args{'Driver'} && !$self->isa( 'DBIx::SearchBuilder::Handle::'. $args{'Driver'} ) ) {
+ if ( $self->_UpgradeHandle($args{Driver}) ) {
+ return ($self->Connect( %args ));
+ }
+ }
+
+
+ my $dsn = $self->DSN || '';
# Setting this actually breaks old RT versions in subtle ways. So we need to explicitly call it
$self->{'DisconnectHandleOnDestroy'} = $args{'DisconnectHandleOnDestroy'};
+
$self->BuildDSN(%args);
@@ -103,15 +113,36 @@ sub Connect {
#Set the handle
$self->dbh($handle);
+
return (1);
}
return(undef);
}
-# }}}
-# {{{ BuildDSN
+
+=head2 _UpgradeHandle DRIVER
+
+This private internal method turns a plain DBIx::SearchBuilder::Handle into one
+of the standard driver-specific subclasses.
+
+=cut
+
+sub _UpgradeHandle {
+ my $self = shift;
+
+ my $driver = shift;
+ my $class = 'DBIx::SearchBuilder::Handle::' . $driver;
+ eval "require $class";
+ return if $@;
+
+ bless $self, $class;
+ return 1;
+}
+
+
+
=head2 BuildDSN PARAMHASH
@@ -144,9 +175,7 @@ sub BuildDSN {
$self->{'dsn'}= $dsn;
}
-# }}}
-# {{{ DSN
=head2 DSN
@@ -158,9 +187,7 @@ sub DSN {
return($self->{'dsn'});
}
-# }}}
-# {{{ RaiseError
=head2 RaiseError [MODE]
@@ -178,9 +205,7 @@ sub RaiseError {
}
-# }}}
-# {{{ PrintError
=head2 PrintError [MODE]
@@ -198,7 +223,6 @@ sub PrintError {
}
-# }}}
=head2 LogSQLStatements BOOL
@@ -212,11 +236,10 @@ Returns whether we're currently logging or not as a boolean
sub LogSQLStatements {
my $self = shift;
if (@_) {
-
require Time::HiRes;
- $self->{'_DoLogSQL'} = shift;
- return ($self->{'_DoLogSQL'});
+ $self->{'_DoLogSQL'} = shift;
}
+ return ($self->{'_DoLogSQL'});
}
=head2 _LogSQLStatement STATEMENT DURATION
@@ -229,7 +252,8 @@ sub _LogSQLStatement {
my $self = shift;
my $statement = shift;
my $duration = shift;
- push @{$self->{'StatementLog'}} , ([Time::Hires::time(), $statement, $duration]);
+ my @bind = @_;
+ push @{$self->{'StatementLog'}} , ([Time::HiRes::time(), $statement, [@bind], $duration]);
}
@@ -261,7 +285,6 @@ sub SQLStatementLog {
}
-# {{{ AutoCommit
=head2 AutoCommit [MODE]
@@ -279,9 +302,7 @@ sub AutoCommit {
}
-# }}}
-# {{{ sub Disconnect
=head2 Disconnect
@@ -298,9 +319,7 @@ sub Disconnect {
}
}
-# }}}
-# {{{ sub Handle / dbh
=head2 dbh [HANDLE]
@@ -320,9 +339,7 @@ sub dbh {
return($DBIHandle{$self} ||= $PrevHandle);
}
-# }}}
-# {{{ sub Insert
=head2 Insert $TABLE_NAME @KEY_VALUE_PAIRS
Takes a table name and a set of key-value pairs in an array. splits the key value pairs, constructs an INSERT statement and performs the insert. Returns the row_id of this row.
@@ -349,9 +366,7 @@ sub Insert {
my $sth = $self->SimpleQuery($QueryString, @bind);
return ($sth);
}
-# }}}
-# {{{ sub UpdateRecordValue
=head2 UpdateRecordValue
@@ -421,9 +436,7 @@ sub UpdateTableValue {
return $self->UpdateRecordValue(%args)
}
-# }}}
-# {{{ sub SimpleQuery
=head2 SimpleQuery QUERY_STRING, [ BIND_VALUE, ... ]
@@ -480,8 +493,7 @@ sub SimpleQuery {
eval { $executed = $sth->execute(@bind_values) };
}
if ( $self->LogSQLStatements ) {
- $self->_LogSQLStatement( $QueryString, tv_interval($basetime) );
-
+ $self->_LogSQLStatement( $QueryString, Time::HiRes::time() - $basetime, @bind_values );
}
if ( $@ or !$executed ) {
@@ -491,7 +503,7 @@ sub SimpleQuery {
}
else {
- warn "$self couldn't execute the query '$QueryString'";
+ cluck "$self couldn't execute the query '$QueryString'";
my $ret = Class::ReturnValue->new();
$ret->as_error(
@@ -508,9 +520,7 @@ sub SimpleQuery {
}
-# }}}
-# {{{ sub FetchResult
=head2 FetchResult QUERY, [ BIND_VALUE, ... ]
@@ -533,9 +543,7 @@ sub FetchResult {
return($sth);
}
}
-# }}}
-# {{{ BinarySafeBLOBs
=head2 BinarySafeBLOBs
@@ -549,9 +557,7 @@ sub BinarySafeBLOBs {
return(1);
}
-# }}}
-# {{{ KnowsBLOBs
=head2 KnowsBLOBs
@@ -565,9 +571,7 @@ sub KnowsBLOBs {
return(1);
}
-# }}}
-# {{{ BLOBParams
=head2 BLOBParams FIELD_NAME FIELD_TYPE
@@ -582,9 +586,7 @@ sub BLOBParams {
return ( {} );
}
-# }}}
-# {{{ DatabaseVersion
=head2 DatabaseVersion
@@ -602,9 +604,7 @@ sub DatabaseVersion {
$self->{'database_version'}= $vals[0];
}
}
-# }}}
-# {{{ CaseSensitive
=head2 CaseSensitive
@@ -619,10 +619,8 @@ sub CaseSensitive {
}
-# }}}
-# {{{ _MakeClauseCaseInsensitive
=head2 _MakeClauseCaseInsensitive FIELD OPERATOR VALUE
@@ -647,9 +645,7 @@ sub _MakeClauseCaseInsensitive {
}
-# }}}
-# {{{ BeginTransaction
=head2 BeginTransaction
@@ -670,9 +666,7 @@ sub BeginTransaction {
}
}
-# }}}
-# {{{ Commit
=head2 Commit
@@ -693,9 +687,7 @@ sub Commit {
}
}
-# }}}
-# {{{ Rollback
=head2 Rollback [FORCE]
@@ -724,7 +716,6 @@ sub Rollback {
}
}
-# }}}
=head2 ForceRollback
@@ -750,7 +741,6 @@ sub TransactionDepth {
}
-# {{{ ApplyLimits
=head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW
@@ -780,10 +770,8 @@ sub ApplyLimits {
}
-# }}}
-# {{{ Join
=head2 Join { Paramhash }
@@ -864,7 +852,6 @@ sub Join {
if ( !$alias || $args{'ALIAS1'} ) {
return ( $self->_NormalJoin(%args) );
}
-
$args{'SearchBuilder'}->{'aliases'} = \@new_aliases;
}
@@ -920,7 +907,6 @@ sub _NormalJoin {
if ( $args{'TYPE'} =~ /LEFT/i ) {
my $alias = $sb->_GetAlias( $args{'TABLE2'} );
-
$sb->{'left_joins'}{"$alias"}{'alias_string'} =
" LEFT JOIN $args{'TABLE2'} $alias ";
@@ -958,7 +944,7 @@ sub _BuildJoins {
}
}
- my $join_clause = $sb->{'table'} . " main ";
+ my $join_clause = $sb->Table . " main ";
my @keys = ( keys %{ $sb->{'left_joins'} } );
@@ -987,9 +973,7 @@ sub _BuildJoins {
}
-# }}}
-# {{{ DistinctQuery
=head2 DistinctQuery STATEMENTREF
@@ -1008,10 +992,8 @@ sub DistinctQuery {
}
-# }}}
-# {{{ DistinctCount
=head2 DistinctCount STATEMENTREF
@@ -1029,7 +1011,6 @@ sub DistinctCount {
}
-# }}}
=head2 Log MESSAGE
@@ -1065,7 +1046,6 @@ sub DESTROY {
1;
__END__
-# {{{ POD
=head1 AUTHOR
@@ -1077,4 +1057,3 @@ perl(1), L<DBIx::SearchBuilder>
=cut
-# }}}
@@ -11,7 +11,6 @@ use Cache::Simple::TimedExpiry;
use strict;
-# {{{ Doc
=head1 NAME
@@ -32,7 +31,6 @@ The public interface remains the same, except that records which have been loade
=cut
-# }}}
my %_CACHES = ();
@@ -228,7 +226,7 @@ sub _serialize {
return (
{
values => $self->{'values'},
- table => $self->{'table'},
+ table => $self->Table,
fetched => $self->{'fetched'}
}
);
@@ -346,7 +344,6 @@ sub _CacheConfig {
__END__
-# {{{ POD
=head1 AUTHOR
@@ -358,5 +355,4 @@ L<DBIx::SearchBuilder>, L<DBIx::SearchBuilder::Record>
=cut
-# }}}
@@ -8,7 +8,6 @@ use vars qw($AUTOLOAD);
use Class::ReturnValue;
-# {{{ Doc
=head1 NAME
@@ -336,13 +335,15 @@ For simple use, thats more or less all there is to it. In the future, I hope to
this HowTo to discuss using container classes, overloading, and what
ever else I think of.
+=head1 METHOD NAMING
+Each method has a lower case alias; '_' is used to separate words.
+For example, the method C<_PrimaryKeys> has the alias C<_primary_keys>.
=head1 METHODS
=cut
-# }}}
=head2 new
@@ -352,7 +353,6 @@ Instantiate a new record object.
=cut
-
sub new {
my $proto = shift;
@@ -364,9 +364,14 @@ sub new {
return $self;
}
-# }}}
-# {{{ sub Id and id
+# Not yet documented here. Should almost certainly be overloaded.
+sub _Init {
+ my $self = shift;
+ my $handle = shift;
+ $self->_Handle($handle);
+}
+
=head2 id
@@ -375,14 +380,15 @@ Returns this row's primary key.
=cut
-*Id = \&id;
-sub id {
+*id = \&Id;
+
+sub Id {
my $pkey = $_[0]->_PrimaryKey();
- $_[0]->{'values'}->{$pkey};
+ my $ret = $_[0]->{'values'}->{$pkey};
+ return $ret;
}
-# }}}
=head2 primary_keys
@@ -394,7 +400,7 @@ Return a hash of the values of our primary keys for this function.
-*primary_keys = \&PrimaryKeys;
+
sub PrimaryKeys {
my $self = shift;
my %hash = map { $_ => $self->{'values'}->{$_} } @{$self->_PrimaryKeys};
@@ -403,46 +409,51 @@ sub PrimaryKeys {
-# {{{ Routines dealing with getting and setting row data
-# {{{ sub DESTROY
sub DESTROY {
return 1;
}
-# }}}
-# {{{ sub AUTOLOAD
sub AUTOLOAD {
- my $self = shift;
+ my $self = $_[0];
no strict 'refs';
- my $Attrib;
- if ( $AUTOLOAD =~ /.*::(\w+)/o ) {
- $Attrib = $1;
- }
- if ( $Attrib && $self->_Accessible( $Attrib, 'read' ) ) {
+ my ($Attrib) = ( $AUTOLOAD =~ /::(\w+)$/o );
+
+ if ( $self->_Accessible( $Attrib, 'read' ) ) {
*{$AUTOLOAD} = sub { return ( $_[0]->_Value($Attrib) ) };
- return ( $self->_Value($Attrib) );
+ goto &$AUTOLOAD;
+ }
+ elsif ( $self->_Accessible( $Attrib, 'record-read') ) {
+ *{$AUTOLOAD} = sub { $_[0]->_ToRecord( $Attrib, $_[0]->__Value($Attrib) ) };
+ goto &$AUTOLOAD;
+ }
+ elsif ( $self->_Accessible( $Attrib, 'foreign-collection') ) {
+ *{$AUTOLOAD} = sub { $_[0]->_CollectionValue( $Attrib ) };
+ goto &$AUTOLOAD;
}
elsif ( $AUTOLOAD =~ /.*::[sS]et_?(\w+)/o ) {
- $Attrib = $1;
+ $Attrib = $1;
if ( $self->_Accessible( $Attrib, 'write' ) ) {
-
*{$AUTOLOAD} = sub {
return ( $_[0]->_Set( Field => $Attrib, Value => $_[1] ) );
};
+ goto &$AUTOLOAD;
+ } elsif ( $self->_Accessible( $Attrib, 'record-write') ) {
+ *{$AUTOLOAD} = sub {
+ my $self = shift;
+ my $val = shift;
- my $Value = shift @_;
- return ( $self->_Set( Field => $Attrib, Value => $Value ) );
+ $val = $val->id if UNIVERSAL::isa($val, 'DBIx::SearchBuilder::Record');
+ return ( $self->_Set( Field => $Attrib, Value => $val ) );
+ };
+ goto &$AUTOLOAD;
}
-
elsif ( $self->_Accessible( $Attrib, 'read' ) ) {
- *{$AUTOLOAD} = sub {
- return ( 0, 'Immutable field' );
- };
- return ( 0, 'Immutable field' );
+ *{$AUTOLOAD} = sub { return ( 0, 'Immutable field' ) };
+ goto &$AUTOLOAD;
}
else {
return ( 0, 'Nonexistant field?' );
@@ -452,13 +463,12 @@ sub AUTOLOAD {
$Attrib = $1;
if ( $self->_Accessible( $Attrib, 'object' ) ) {
*{$AUTOLOAD} = sub {
- my $s = shift;
- return $s->_Object(
+ return (shift)->_Object(
Field => $Attrib,
Args => [@_],
);
};
- return $self->_Object( Field => $Attrib, Args => [@_] );
+ goto &$AUTOLOAD;
}
else {
return ( 0, 'No object mapping for field' );
@@ -473,8 +483,7 @@ sub AUTOLOAD {
$Attrib = $1;
*{$AUTOLOAD} = sub { return ( $_[0]->_Validate( $Attrib, $_[1] ) ) };
- my $Value = shift @_;
- return ( $self->_Validate( $Attrib, $Value ) );
+ goto &$AUTOLOAD;
}
# TODO: if autoload = 0 or 1 _ then a combination of lowercase and _ chars,
@@ -489,9 +498,7 @@ sub AUTOLOAD {
}
-# }}}
-# {{{ sub _Accessible
=head2 _Accessible KEY MODE
@@ -501,7 +508,7 @@ Returns undef unless C<KEY> is accessible in C<MODE> otherwise returns C<MODE> v
=cut
-*_accessible = \&_Accessible;
+
sub _Accessible {
my $self = shift;
my $attr = shift;
@@ -512,7 +519,6 @@ sub _Accessible {
return $attribute->{$mode};
}
-# }}}
=head2 _PrimaryKeys
@@ -535,12 +541,13 @@ sub _PrimaryKey {
return $pkeys->[0];
}
-# {{{ sub _ClassAccessible
=head2 _ClassAccessible
-Preferred and most efficient way to specify fields attributes in a derived
-class.
+An older way to specify fields attributes in a derived class.
+(The current preferred method is by overriding C<Schema>; if you do
+this and don't override C<_ClassAccessible>, the module will generate
+an appropriate C<_ClassAccessible> based on your C<Schema>.)
Here's an example declaration:
@@ -554,11 +561,15 @@ Here's an example declaration:
=cut
-# XXX This is stub code to deal with the old way we used to do _Accessible
-# It should never be called by modern code
sub _ClassAccessible {
my $self = shift;
+
+ return $self->_ClassAccessibleFromSchema if $self->can('Schema');
+
+ # XXX This is stub code to deal with the old way we used to do _Accessible
+ # It should never be called by modern code
+
my %accessible;
while ( my $col = shift ) {
$accessible{$col}->{lc($_)} = 1
@@ -567,7 +578,85 @@ sub _ClassAccessible {
return(\%accessible);
}
-# }}}
+sub _ClassAccessibleFromSchema {
+ my $self = shift;
+
+ my $accessible = {};
+ foreach my $key ($self->_PrimaryKeys) {
+ $accessible->{$key} = { 'read' => 1 };
+ };
+
+ my $schema = $self->Schema;
+
+ for my $field (keys %$schema) {
+ if ($schema->{$field}{'TYPE'}) {
+ $accessible->{$field} = { 'read' => 1, 'write' => 1 };
+ } elsif (my $refclass = $schema->{$field}{'REFERENCES'}) {
+ if (UNIVERSAL::isa($refclass, 'DBIx::SearchBuilder::Record')) {
+ if ($field =~ /(.*)_id$/) {
+ $accessible->{$field} = { 'read' => 1, 'write' => 1 };
+ $accessible->{$1} = { 'record-read' => 1, 'column' => $field };
+ } else {
+ $accessible->{$field} = { 'record-read' => 1, 'record-write' => 1 };
+ }
+ } elsif (UNIVERSAL::isa($refclass, 'DBIx::SearchBuilder')) {
+ $accessible->{$field} = { 'foreign-collection' => 1 };
+ } else {
+ warn "Error: $refclass neither Record nor Collection";
+ }
+ }
+ }
+
+ return $accessible;
+}
+
+
+sub _ToRecord {
+ my $self = shift;
+ my $field = shift;
+ my $value = shift;
+
+ return unless defined $value;
+
+ my $schema = $self->Schema;
+ my $description = $schema->{$field} || $schema->{$field . "_id"};
+
+ die "Can't get schema for $field on $self" unless $description;
+
+ return unless $description;
+
+ return $value unless $description->{'REFERENCES'};
+
+ my $classname = $description->{'REFERENCES'};
+
+ return unless UNIVERSAL::isa($classname, 'DBIx::SearchBuilder::Record');
+
+ # XXX TODO FIXME perhaps this is not what should be passed to new, but it needs it
+ my $object = $classname->new( $self->_Handle );
+ $object->LoadById( $value );
+ return $object;
+}
+
+sub _CollectionValue {
+ my $self = shift;
+
+ my $method_name = shift;
+ return unless defined $method_name;
+
+ my $schema = $self->Schema;
+ my $description = $schema->{$method_name};
+ return unless $description;
+
+ my $classname = $description->{'REFERENCES'};
+
+ return unless UNIVERSAL::isa($classname, 'DBIx::SearchBuilder');
+
+ my $coll = $classname->new( Handle => $self->_Handle );
+
+ $coll->Limit( FIELD => $description->{'KEY'}, VALUE => $self->id);
+
+ return $coll;
+}
# sub {{{ ReadableAttributes
@@ -580,13 +669,11 @@ Returns an array of the attributes of this class defined as "read" => 1 in this
sub ReadableAttributes {
my $self = shift;
my $ca = $self->_ClassAccessible();
- my @readable = grep { $ca->{$_}->{read}} keys %{$ca};
+ my @readable = grep { $ca->{$_}->{'read'} or $ca->{$_}->{'record-read'} } keys %{$ca};
return (@readable);
}
-# }}}
-# {{{ sub WritableAttributes
=head2 WritableAttributes
@@ -597,15 +684,12 @@ Returns an array of the attributes of this class defined as "write" => 1 in this
sub WritableAttributes {
my $self = shift;
my $ca = $self->_ClassAccessible();
- my @writable = grep { $ca->{$_}->{write}} keys %{$ca};
- return (@writable);
-
+ my @writable = grep { $ca->{$_}->{'write'} || $ca->{$_}->{'record-write'} } keys %{$ca};
+ return @writable;
}
-# }}}
-# {{{ sub __Value {
=head2 __Value
@@ -614,10 +698,12 @@ override __Value.
=cut
-*__value = \&__Value;
+
sub __Value {
my $self = shift;
- my $field = lc(shift);
+ my $field = lc shift;
+
+ $field = $self->_Accessible($field, "column") while $self->_Accessible($field, "column");
if (!$self->{'fetched'}{$field} and my $id = $self->id() ) {
my $pkey = $self->_PrimaryKey();
@@ -630,10 +716,10 @@ sub __Value {
$self->{'fetched'}{$field} = 1;
}
- return($self->{'values'}{$field});
+ my $value = $self->{'values'}{$field};
+
+ return $value;
}
-# }}}
-# {{{ sub _Value
=head2 _Value
@@ -642,15 +728,13 @@ Subclasses can override _Value to insert custom access control.
=cut
-*_value = \&_Value;
+
sub _Value {
my $self = shift;
return ($self->__Value(@_));
}
-# }}}
-# {{{ sub _Set
=head2 _Set
@@ -660,7 +744,7 @@ Subclasses can override _Set to insert custom access control.
=cut
-*_set = \&_Set;
+
sub _Set {
my $self = shift;
return ($self->__Set(@_));
@@ -668,7 +752,7 @@ sub _Set {
-*__set = \&__Set;
+
sub __Set {
my $self = shift;
@@ -679,16 +763,12 @@ sub __Set {
@_
);
- $args{'Column'} = $args{'Field'};
- $args{'IsSQLFunction'} = $args{'IsSQL'};
+ $args{'Column'} = delete $args{'Field'};
+ $args{'IsSQLFunction'} = delete $args{'IsSQL'};
my $ret = Class::ReturnValue->new();
- ## Cleanup the hash.
- delete $args{'Field'};
- delete $args{'IsSQL'};
-
- unless ( defined( $args{'Column'} ) && $args{'Column'} ) {
+ unless ( $args{'Column'} ) {
$ret->as_array( 0, 'No column specified' );
$ret->as_error(
errno => 5,
@@ -698,23 +778,23 @@ sub __Set {
return ( $ret->return_value );
}
my $column = lc $args{'Column'};
- if ( ( defined $self->__Value($column) )
- and ( $args{'Value'} eq $self->__Value($column) ) )
- {
- $ret->as_array( 0, "That is already the current value" );
+ if ( !defined( $args{'Value'} ) ) {
+ $ret->as_array( 0, "No value passed to _Set" );
$ret->as_error(
- errno => 1,
+ errno => 2,
do_backtrace => 0,
- message => "That is already the current value"
+ message => "No value passed to _Set"
);
return ( $ret->return_value );
}
- elsif ( !defined( $args{'Value'} ) ) {
- $ret->as_array( 0, "No value passed to _Set" );
+ elsif ( ( defined $self->__Value($column) )
+ and ( $args{'Value'} eq $self->__Value($column) ) )
+ {
+ $ret->as_array( 0, "That is already the current value" );
$ret->as_error(
- errno => 2,
+ errno => 1,
do_backtrace => 0,
- message => "No value passed to _Set"
+ message => "That is already the current value"
);
return ( $ret->return_value );
}
@@ -783,13 +863,62 @@ sub __Set {
return ( $ret->return_value );
}
-# }}}
+=head2 _Canonicalize PARAMHASH
+
+This routine massages an input value (VALUE) for FIELD into something that's
+going to be acceptable.
+
+Takes
+
+=over
+
+=item FIELD
+
+=item VALUE
+
+=item FUNCTION
+
+=back
+
+
+Takes:
+
+=over
+
+=item FIELD
+
+=item VALUE
+
+=item FUNCTION
+
+=back
+
+Returns a replacement VALUE.
+
+=cut
+
+sub _Canonicalize {
+ my $self = shift;
+ my $field = shift;
+
+
+
+}
+
+
+=head2 _Validate FIELD VALUE
+
+Validate that VALUE will be an acceptable value for FIELD.
+
+Currently, this routine does nothing whatsoever.
+
+If it succeeds (which is always the case right now), returns true. Otherwise returns false.
+
+=cut
+
-# {{{ sub _Validate
-#TODO: Implement _Validate.
-*_validate = \&_Validate;
sub _Validate {
my $self = shift;
my $field = shift;
@@ -806,9 +935,7 @@ sub _Validate {
return(1);
}
-# }}}
-# {{{ sub TruncateValue
=head2 TruncateValue KEY VALUE
@@ -861,9 +988,7 @@ sub TruncateValue {
}
}
-# }}}
-# {{{ sub _Object
=head2 _Object
@@ -875,6 +1000,10 @@ the object constructor's arguments.
Subclasses can override _Object to insert custom access control or
define default contructor arguments.
+Note that if you are using a C<Schema> with a C<REFERENCES> field,
+this is unnecessary: the method to access the column's value will
+automatically turn it into the appropriate object.
+
=cut
sub _Object {
@@ -906,11 +1035,8 @@ sub __Object {
return $object;
}
-# }}}
-# {{{ routines dealing with loading records
-# {{{ sub Load
# load should do a bit of overloading
# if we call it with only one argument, we're trying to load by reference.
@@ -926,15 +1052,13 @@ is $id
=cut
-*load = \&Load;
+
sub Load {
my $self = shift;
# my ($package, $filename, $line) = caller;
return $self->LoadById(@_);
}
-# }}}
-# {{{ sub LoadByCol
=head2 LoadByCol
@@ -944,7 +1068,7 @@ undefined
=cut
-*load_by_col = \&LoadByCol;
+
sub LoadByCol {
my $self = shift;
@@ -954,9 +1078,7 @@ sub LoadByCol {
return($self->LoadByCols($col => $val));
}
-# }}}
-# {{{ sub LoadByCols
=head2 LoadByCols
@@ -970,7 +1092,7 @@ OR has references which contain 'operator' and 'value'
=cut
-*load_by_cols = \&LoadByCols;
+
sub LoadByCols {
my $self = shift;
my %hash = (@_);
@@ -993,7 +1115,16 @@ sub LoadByCols {
push @bind, $value;
}
else {
- push @phrases, "($key IS NULL OR $key = '')";
+ push @phrases, "($key IS NULL OR $key = ?)";
+ my $meta = $self->_ClassAccessible->{$key};
+ $meta->{'type'} ||= '';
+ # TODO: type checking should be done in generic way
+ if ( $meta->{'is_numeric'} || $meta->{'type'} =~ /INT|NUMERIC|DECIMAL|REAL|DOUBLE|FLOAT/i ) {
+ push @bind, 0;
+ } else {
+ push @bind, '';
+ }
+
}
}
@@ -1003,9 +1134,7 @@ sub LoadByCols {
}
-# }}}
-# {{{ sub LoadById
=head2 LoadById
@@ -1013,7 +1142,7 @@ Loads a record by its primary key. Your record class must define a single primar
=cut
-*load_by_id = \&LoadById;
+
sub LoadById {
my $self = shift;
my $id = shift;
@@ -1023,10 +1152,8 @@ sub LoadById {
return ($self->LoadByCols($pkey => $id));
}
-# }}}
-# {{{ LoadByPrimaryKeys
=head2 LoadByPrimaryKeys
@@ -1034,27 +1161,22 @@ Like LoadById with basic support for compound primary keys.
=cut
-*load_by_primary_keys = \&LoadByPrimaryKeys;
+
sub LoadByPrimaryKeys {
- my ($self, $data) = @_;
+ my $self = shift;
+ my $data = (ref $_[0] eq 'HASH')? $_[0]: {@_};
- if (ref($data) eq 'HASH') {
- my %cols=();
- foreach (@{$self->_PrimaryKeys}) {
- $cols{$_}=$data->{$_} if (exists($data->{$_}));
- }
- return ($self->LoadByCols(%cols));
- }
- else {
- return (0, "Invalid data");
+ my %cols=();
+ foreach (@{$self->_PrimaryKeys}) {
+ return (0, "Missing PK field: '$_'") unless defined $data->{$_};
+ $cols{$_}=$data->{$_};
}
+ return ($self->LoadByCols(%cols));
}
-# }}}
-# {{{ sub LoadFromHash
=head2 LoadFromHash
@@ -1063,7 +1185,7 @@ loaded values hash.
=cut
-*load_from_hash = \&LoadFromHash;
+
sub LoadFromHash {
my $self = shift;
@@ -1077,9 +1199,7 @@ sub LoadFromHash {
return $self->id();
}
-# }}}
-# {{{ sub _LoadFromSQL
=head2 _LoadFromSQL QUERYSTRING @BIND_VALUES
@@ -1087,7 +1207,7 @@ Load a record as the result of an SQL statement
=cut
-*load_from_sql = \&LoadFromSQL;
+
sub _LoadFromSQL {
@@ -1099,42 +1219,35 @@ sub _LoadFromSQL {
#TODO this only gets the first row. we should check if there are more.
- unless ($sth) {
- return($sth);
- }
+ return ( 0, "Couldn't execute query" ) unless $sth;
- eval { $self->{'values'} = $sth->fetchrow_hashref; };
- if ($@) {
- warn $@;
+ $self->{'values'} = $sth->fetchrow_hashref;
+ $self->{'fetched'} = {};
+ if ( !$self->{'values'} && $sth->err ) {
+ return ( 0, "Couldn't fetch row: ". $sth->err );
}
unless ( $self->{'values'} ) {
return ( 0, "Couldn't find row" );
}
-
- foreach my $f ( keys %{$self->{'values'}||{}} ) {
- $self->{'fetched'}{lc $f} = 1;
- }
-
## I guess to be consistant with the old code, make sure the primary
## keys exist.
- eval { $self->PrimaryKeys(); };
- if ($@) {
- return ( 0, "Missing a primary key?: $@" );
+ if( grep { not defined } $self->PrimaryKeys ) {
+ return ( 0, "Missing a primary key?" );
+ }
+
+ foreach my $f ( keys %{$self->{'values'}} ) {
+ $self->{'fetched'}{lc $f} = 1;
}
return ( 1, "Found Object" );
}
-# }}}
-# }}}
-# {{{ Routines dealing with creating or deleting rows in the DB
-# {{{ sub Create
=head2 Create
@@ -1143,7 +1256,7 @@ as columns for this recordtype
=cut
-*create = \&Create;
+
sub Create {
my $self = shift;
@@ -1151,21 +1264,25 @@ sub Create {
my ($key);
foreach $key ( keys %attribs ) {
- my $method = "Validate$key";
- #Truncate things that are too long for their datatypes
- $attribs{$key} = $self->TruncateValue ($key => $attribs{$key});
-
- unless ( $self->$method( $attribs{$key} ) ) {
- delete $attribs{$key};
+ if ( $self->_Accessible( $key, 'record-write' ) ) {
+ $attribs{$key} = $attribs{$key}->id
+ if UNIVERSAL::isa( $attribs{$key},
+ 'DBIx::SearchBuilder::Record' );
}
+
+ #Truncate things that are too long for their datatypes
+ $attribs{$key} = $self->TruncateValue( $key => $attribs{$key} );
+
}
unless ( $self->_Handle->KnowsBLOBs ) {
+
# Support for databases which don't deal with LOBs automatically
my $ca = $self->_ClassAccessible();
foreach $key ( keys %attribs ) {
if ( $ca->{$key}->{'type'} =~ /^(text|longtext|clob|blob|lob)$/i ) {
- my $bhash = $self->_Handle->BLOBParams( $key, $ca->{$key}->{'type'} );
+ my $bhash =
+ $self->_Handle->BLOBParams( $key, $ca->{$key}->{'type'} );
$bhash->{'value'} = $attribs{$key};
$attribs{$key} = $bhash;
}
@@ -1174,9 +1291,6 @@ sub Create {
return ( $self->_Handle->Insert( $self->Table, %attribs ) );
}
-# }}}
-
-# {{{ sub Delete
=head2 Delete
@@ -1216,12 +1330,9 @@ sub __Delete {
}
}
-# }}}
-# }}}
-# {{{ sub Table
=head2 Table
@@ -1229,7 +1340,7 @@ Returns or sets the name of the current Table
=cut
-*table = \&Table;
+
sub Table {
my $self = shift;
@@ -1239,9 +1350,7 @@ sub Table {
return ($self->{'table'});
}
-# }}}
-# {{{ sub _Handle
=head2 _Handle
@@ -1249,7 +1358,7 @@ Returns or sets the current DBIx::SearchBuilder::Handle object
=cut
-*_handle = \&_Handle;
+
sub _Handle {
my $self = shift;
if (@_) {
@@ -1258,14 +1367,15 @@ sub _Handle {
return ($self->{'DBIxHandle'});
}
-# }}}
+if( eval { require capitalization } ) {
+ capitalization->unimport( __PACKAGE__ );
+}
1;
__END__
-# {{{ POD
=head1 AUTHOR
@@ -1282,5 +1392,4 @@ L<DBIx::SearchBuilder>
=cut
-# }}}
@@ -0,0 +1,306 @@
+use strict;
+use warnings;
+
+package DBIx::SearchBuilder::SchemaGenerator;
+
+use base qw(Class::Accessor);
+use DBIx::DBSchema;
+use Class::ReturnValue;
+
+# Public accessors
+__PACKAGE__->mk_accessors(qw(handle));
+# Internal accessors: do not use from outside class
+__PACKAGE__->mk_accessors(qw(_db_schema));
+
+=head2 new HANDLE
+
+Creates a new C<DBIx::SearchBuilder::SchemaGenerator> object. The single
+required argument is a C<DBIx::SearchBuilder::Handle>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $handle = shift;
+ my $self = $class->SUPER::new();
+
+ $self->handle($handle);
+
+ my $schema = DBIx::DBSchema->new;
+ $self->_db_schema($schema);
+
+ return $self;
+}
+
+=for public_doc AddModel MODEL
+
+Adds a new model class to the SchemaGenerator. Model should either be an object
+of a subclass of C<DBIx::SearchBuilder::Record>, or the name of such a subclass; in the
+latter case, C<AddModel> will instantiate an object of the subclass.
+
+The model must define the instance methods C<Schema> and C<Table>.
+
+Returns true if the model was added successfully; returns a false C<Class::ReturnValue> error
+otherwise.
+
+=cut
+
+sub AddModel {
+ my $self = shift;
+ my $model = shift;
+
+ # $model could either be a (presumably unfilled) object of a subclass of
+ # DBIx::SearchBuilder::Record, or it could be the name of such a subclass.
+
+ unless (ref $model and UNIVERSAL::isa($model, 'DBIx::SearchBuilder::Record')) {
+ my $new_model;
+ eval { $new_model = $model->new; };
+
+ if ($@) {
+ return $self->_error("Error making new object from $model: $@");
+ }
+
+ return $self->_error("Didn't get a DBIx::SearchBuilder::Record from $model, got $new_model")
+ unless UNIVERSAL::isa($new_model, 'DBIx::SearchBuilder::Record');
+
+ $model = $new_model;
+ }
+
+ my $table_obj = $self->_DBSchemaTableFromModel($model);
+
+ $self->_db_schema->addtable($table_obj);
+
+ 1;
+}
+
+=for public_doc CreateTableSQLStatements
+
+Returns a list of SQL statements (as strings) to create tables for all of
+the models added to the SchemaGenerator.
+
+=cut
+
+sub CreateTableSQLStatements {
+ my $self = shift;
+ # The sort here is to make it predictable, so that we can write tests.
+ return sort $self->_db_schema->sql($self->handle->dbh);
+}
+
+=for public_doc CreateTableSQLText
+
+Returns a string containg a sequence of SQL statements to create tables for all of
+the models added to the SchemaGenerator.
+
+=cut
+
+sub CreateTableSQLText {
+ my $self = shift;
+
+ return join "\n", map { "$_ ;\n" } $self->CreateTableSQLStatements;
+}
+
+=for private_doc _DBSchemaTableFromModel MODEL
+
+Takes an object of a subclass of DBIx::SearchBuilder::Record; returns a new
+C<DBIx::DBSchema::Table> object corresponding to the model.
+
+=cut
+
+sub _DBSchemaTableFromModel {
+ my $self = shift;
+ my $model = shift;
+
+ my $table_name = $model->Table;
+ my $schema = $model->Schema;
+
+ my $primary = "id"; # TODO allow override
+ my $primary_col = DBIx::DBSchema::Column->new({
+ name => $primary,
+ type => 'serial',
+ null => 'NOT NULL',
+ });
+
+ my @cols = ($primary_col);
+
+ # The sort here is to make it predictable, so that we can write tests.
+ for my $field (sort keys %$schema) {
+ # Skip foreign keys
+
+ next if defined $schema->{$field}->{'REFERENCES'} and defined $schema->{$field}->{'KEY'};
+
+ # TODO XXX FIXME
+ # In lieu of real reference support, make references just integers
+ $schema->{$field}{'TYPE'} = 'integer' if $schema->{$field}{'REFERENCES'};
+
+ push @cols, DBIx::DBSchema::Column->new({
+ name => $field,
+ type => $schema->{$field}{'TYPE'},
+ null => 'NULL',
+ default => $schema->{$field}{'DEFAULT'},
+ });
+ }
+
+ my $table = DBIx::DBSchema::Table->new({
+ name => $table_name,
+ primary_key => $primary,
+ columns => \@cols,
+ });
+
+ return $table;
+}
+
+=for private_doc _error STRING
+
+Takes in a string and returns it as a Class::ReturnValue error object.
+
+=cut
+
+sub _error {
+ my $self = shift;
+ my $message = shift;
+
+ my $ret = Class::ReturnValue->new;
+ $ret->as_error(errno => 1, message => $message);
+ return $ret->return_value;
+}
+
+
+1; # Magic true value required at end of module
+__END__
+
+=head1 NAME
+
+DBIx::SearchBuilder::SchemaGenerator - Generate table schemas from DBIx::SearchBuilder records
+
+=head1 SYNOPSIS
+
+ use DBIx::SearchBuilder::SchemaGenerator;
+
+
+=head1 DESCRIPTION
+
+=for author to fill in:
+ Write a full description of the module and its features here.
+ Use subsections (=head2, =head3) as appropriate.
+
+
+=head1 INTERFACE
+
+=for author to fill in:
+ Write a separate section listing the public components of the modules
+ interface. These normally consist of either subroutines that may be
+ exported, or methods that may be called on objects belonging to the
+ classes provided by the module.
+
+
+=head1 DIAGNOSTICS
+
+=for author to fill in:
+ List every single error and warning message that the module can
+ generate (even the ones that will "never happen"), with a full
+ explanation of each problem, one or more likely causes, and any
+ suggested remedies.
+
+=over
+
+=item C<< Error message here, perhaps with %s placeholders >>
+
+[Description of error here]
+
+=item C<< Another error message here >>
+
+[Description of error here]
+
+[Et cetera, et cetera]
+
+=back
+
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+=for author to fill in:
+ A full explanation of any configuration system(s) used by the
+ module, including the names and locations of any configuration
+ files, and the meaning of any environment variables or properties
+ that can be set. These descriptions must also include details of any
+ configuration language used.
+
+<MODULE NAME> requires no configuration files or environment variables.
+
+
+=head1 DEPENDENCIES
+
+=for author to fill in:
+ A list of all the other modules that this module relies upon,
+ including any restrictions on versions, and an indication whether
+ the module is part of the standard Perl distribution, part of the
+ module's distribution, or must be installed separately. ]
+
+None.
+
+
+=head1 INCOMPATIBILITIES
+
+=for author to fill in:
+ A list of any modules that this module cannot be used in conjunction
+ with. This may be due to name conflicts in the interface, or
+ competition for system or program resources, or due to internal
+ limitations of Perl (for example, many modules that use source code
+ filters are mutually incompatible).
+
+None reported.
+
+
+=head1 BUGS AND LIMITATIONS
+
+=for author to fill in:
+ A list of known problems with the module, together with some
+ indication Whether they are likely to be fixed in an upcoming
+ release. Also a list of restrictions on the features the module
+ does provide: data types that cannot be handled, performance issues
+ and the circumstances in which they may arise, practical
+ limitations on the size of data sets, special cases that are not
+ (yet) handled, etc.
+
+No bugs have been reported.
+
+Please report any bugs or feature requests to
+C<bug-<RT NAME>@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org>.
+
+
+=head1 AUTHOR
+
+David Glasser C<< glasser@bestpractical.com >>
+
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) <YEAR>, <AUTHOR> C<< <<EMAIL>> >>. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+
+=head1 DISCLAIMER OF WARRANTY
+
+BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
+EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
+ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
+YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
+NECESSARY SERVICING, REPAIR, OR CORRECTION.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
+LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
+OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
+THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
@@ -17,7 +17,6 @@ sub AddRecord {
$self->{"dbix_sb_unique_cache"} = {} unless (@{$self->{'items'}}[0]);
return if $self->{"dbix_sb_unique_cache"}->{$record->id}++;
push @{$self->{'items'}}, $record;
- $self->{'rows'}++;
}
1;
@@ -1,11 +1,10 @@
-# {{{ Version, package, new, etc
package DBIx::SearchBuilder;
use strict;
use vars qw($VERSION);
-$VERSION = "1.27";
+$VERSION = "1.33";
=head1 NAME
@@ -14,30 +13,74 @@ DBIx::SearchBuilder - Encapsulate SQL queries and rows in simple perl objects
=head1 SYNOPSIS
use DBIx::SearchBuilder;
+
+ package My::Things;
+ use base qw/DBIx::SearchBuilder/;
+
+ sub _Init {
+ my $self = shift;
+ $self->Table('Things');
+ return $self->SUPER::_Init(@_);
+ }
+
+ sub NewItem {
+ my $self = shift;
+ # MyThing is a subclass of DBIx::SearchBuilder::Record
+ return(MyThing->new);
+ }
+
+ package main;
use DBIx::SearchBuilder::Handle;
my $handle = DBIx::SearchBuilder::Handle->new();
$handle->Connect( Driver => 'SQLite', Database => "my_test_db" );
- my $sb = DBIx::SearchBuilder->new( Handle => $handle, Table => "my_table" );
+ my $sb = My::Things->new( Handle => $handle );
$sb->Limit( FIELD => "column_1", VALUE => "matchstring" );
while ( my $record = $sb->Next ) {
- print $record->my_column_name();
+ print $record->my_column_name();
}
=head1 DESCRIPTION
This module provides an object-oriented mechanism for retrieving and updating data in a DBI-accesible database.
+In order to use this module, you should create a subclass of C<DBIx::SearchBuilder> and a
+subclass of C<DBIx::SearchBuilder::Record> for each table that you wish to access. (See
+the documentation of C<DBIx::SearchBuilder::Record> for more information on subclassing it.)
+
+Your C<DBIx::SearchBuilder> subclass must override C<NewItem>, and probably should override
+at least C<_Init> also; at the very least, C<_Init> should probably call C<_Handle> and C<_Table>
+to set the database handle (a C<DBIx::SearchBuilder::Handle> object) and table name for the class.
+You can try to override just about every other method here, as long as you think you know what you
+are doing.
+
+=head1 METHOD NAMING
+
+Each method has a lower case alias; '_' is used to separate words.
+For example, the method C<RedoSearch> has the alias C<redo_search>.
+
=head1 METHODS
=cut
-# {{{ sub new
-#instantiate a new object.
+=head2 new
+
+Creates a new SearchBuilder object and immediately calls C<_Init> with the same parameters
+that were passed to C<new>. If you haven't overridden C<_Init> in your subclass, this means
+that you should pass in a C<DBIx::SearchBuilder::Handle> (or one of its subclasses) like this:
+
+ my $sb = My::DBIx::SearchBuilder::Subclass->new( Handle => $handle );
+
+However, if your subclass overrides _Init you do not need to take a Handle argument, as long
+as your subclass returns an appropriate handle object from the C<_Handle> method. This is
+useful if you want all of your SearchBuilder objects to use a shared global handle and don't want
+to have to explicitly pass it in each time, for example.
+
+=cut
sub new {
my $proto = shift;
@@ -48,30 +91,33 @@ sub new {
return ($self);
}
-# }}}
-# {{{ sub _Init
-#Initialize the object
+=head2 _Init
+
+This method is called by C<new> with whatever arguments were passed to C<new>.
+By default, it takes a C<DBIx::SearchBuilder::Handle> object as a C<Handle>
+argument, although this is not necessary if your subclass overrides C<_Handle>.
+
+=cut
sub _Init {
my $self = shift;
my %args = ( Handle => undef,
@_ );
- $self->{'DBIxHandle'} = $args{'Handle'};
+ $self->_Handle( $args{'Handle'} );
$self->CleanSlate();
}
-# }}}
-# {{{ sub CleanSlate
=head2 CleanSlate
This completely erases all the data in the SearchBuilder object. It's
-useful if a subclass is doing funky stuff to keep track of
-a search
+useful if a subclass is doing funky stuff to keep track of a search and
+wants to reset the SearchBuilder data without losing its own data;
+it's probably cleaner to accomplish that in a different way, though.
=cut
@@ -87,23 +133,26 @@ sub CleanSlate {
$self->{'alias_count'} = 0;
$self->{'first_row'} = 0;
$self->{'must_redo_search'} = 1;
+ $self->{'show_rows'} = 0;
@{ $self->{'aliases'} } = ();
- delete $self->{'items'} if ( defined $self->{'items'} );
- delete $self->{'left_joins'} if ( defined $self->{'left_joins'} );
- delete $self->{'raw_rows'} if ( defined $self->{'raw_rows'} );
- delete $self->{'count_all'} if ( defined $self->{'count_all'} );
- delete $self->{'subclauses'} if ( defined $self->{'subclauses'} );
- delete $self->{'restrictions'} if ( defined $self->{'restrictions'} );
+ delete $self->{$_} for qw(
+ items
+ left_joins
+ raw_rows
+ count_all
+ subclauses
+ restrictions
+ _open_parens
+ _close_parens
+ );
#we have no limit statements. DoSearch won't work.
$self->_isLimited(0);
}
-# }}}
-# {{{ sub _Handle
=head2 _Handle [DBH]
@@ -119,9 +168,13 @@ sub _Handle {
return ( $self->{'DBIxHandle'} );
}
-# }}}
+=head2 _DoSearch
-# {{{ sub _DoSearch
+This internal private method actually executes the search on the database;
+it is called automatically the first time that you actually need results
+(such as a call to C<Next>).
+
+=cut
sub _DoSearch {
my $self = shift;
@@ -131,67 +184,83 @@ sub _DoSearch {
# If we're about to redo the search, we need an empty set of items
delete $self->{'items'};
- eval {
-
- # TODO: finer-grained eval and cheking.
- my $records = $self->_Handle->SimpleQuery($QueryString);
- my $counter;
- $self->{'rows'} = 0;
- while ( my $row = $records->fetchrow_hashref() ) {
- my $item = $self->NewItem();
- $item->LoadFromHash($row);
- $self->AddRecord($item);
- }
+ my $records = $self->_Handle->SimpleQuery($QueryString);
+ return 0 unless $records;
- $self->{'must_redo_search'} = 0;
- };
+ while ( my $row = $records->fetchrow_hashref() ) {
+ my $item = $self->NewItem();
+ $item->LoadFromHash($row);
+ $self->AddRecord($item);
+ }
+ return $self->_RecordCount if $records->err;
- return ( $self->{'rows'});
+ $self->{'must_redo_search'} = 0;
+
+ return $self->_RecordCount;
}
-# }}}
=head2 AddRecord RECORD
-Adds a record object to this collection
+Adds a record object to this collection.
=cut
sub AddRecord {
my $self = shift;
my $record = shift;
- push @{$self->{'items'}}, $record;
- $self->{'rows'}++;
+ push @{$self->{'items'}}, $record;
}
+=head2 _RecordCount
+
+This private internal method returns the number of Record objects saved
+as a result of the last query.
+
+=cut
+
+sub _RecordCount {
+ my $self = shift;
+ return 0 unless defined $self->{'items'};
+ return scalar @{ $self->{'items'} };
+}
+
+
+
+=head2 _DoCount
+
+This internal private method actually executes a counting operation on the database;
+it is used by C<Count> and C<CountAll>.
+
+=cut
-# {{{ sub _DoCount
sub _DoCount {
my $self = shift;
my $all = shift || 0;
my $QueryString = $self->BuildSelectCountQuery();
- eval {
- # TODO: finer-grained Eval
- my $records = $self->_Handle->SimpleQuery($QueryString);
+ my $records = $self->_Handle->SimpleQuery($QueryString);
+ return 0 unless $records;
- my @row = $records->fetchrow_array();
- $self->{ $all ? 'count_all' : 'raw_rows' } = $row[0];
+ my @row = $records->fetchrow_array();
+ return 0 if $records->err;
- return ( $row[0] );
- };
+ $self->{ $all ? 'count_all' : 'raw_rows' } = $row[0];
+
+ return ( $row[0] );
}
-# }}}
=head2 _ApplyLimits STATEMENTREF
This routine takes a reference to a scalar containing an SQL statement.
-It massages the statement to limit the returned rows to $self->RowsPerPage
-starting with $self->FirstRow
-
+It massages the statement to limit the returned rows to only C<< $self->RowsPerPage >>
+rows, skipping C<< $self->FirstRow >> rows. (That is, if rows are numbered
+starting from 0, row number C<< $self->FirstRow >> will be the first row returned.)
+Note that it probably makes no sense to set these variables unless you are also
+enforcing an ordering on the rows (with C<OrderByCols>, say).
=cut
@@ -201,21 +270,15 @@ sub _ApplyLimits {
my $statementref = shift;
$self->_Handle->ApplyLimits($statementref, $self->RowsPerPage, $self->FirstRow);
$$statementref =~ s/main\.\*/join(', ', @{$self->{columns}})/eg
- if $self->{columns} and @{$self->{columns}};
- if (my $groupby = $self->_GroupClause) {
- $$statementref =~ s/(LIMIT \d+)?$/$groupby $1/;
- }
-
+ if $self->{columns} and @{$self->{columns}};
}
-# {{{ sub _DistinctQuery
=head2 _DistinctQuery STATEMENTREF
This routine takes a reference to a scalar containing an SQL statement.
It massages the statement to ensure a distinct result set is returned.
-
=cut
sub _DistinctQuery {
@@ -232,13 +295,9 @@ sub _DistinctQuery {
}
}
-# }}}
-
-# {{{ sub _BuildJoins
-
=head2 _BuildJoins
-Build up all of the joins we need to perform this query
+Build up all of the joins we need to perform this query.
=cut
@@ -250,12 +309,10 @@ sub _BuildJoins {
}
-# }}}
-# {{{ sub _isJoined
=head2 _isJoined
-Returns true if this Searchbuilder requires joins between tables
+Returns true if this SearchBuilder will be joining multiple tables together.
=cut
@@ -269,10 +326,8 @@ sub _isJoined {
}
-# }}}
-# {{{ sub _LimitClause
# LIMIT clauses are used for restricting ourselves to subsets of the search.
@@ -295,9 +350,7 @@ sub _LimitClause {
return $limit_clause;
}
-# }}}
-# {{{ sub _isLimited
=head2 _isLimited
@@ -315,11 +368,8 @@ sub _isLimited {
}
}
-# }}}
-# }}} Private utility methods
-# {{{ BuildSelectQuery
=head2 BuildSelectQuery
@@ -338,12 +388,14 @@ sub BuildSelectQuery {
# DISTINCT query only required for multi-table selects
if ($self->_isJoined) {
- $self->_DistinctQuery(\$QueryString, $self->{'table'});
+ $self->_DistinctQuery(\$QueryString, $self->Table);
} else {
$QueryString = "SELECT main.* FROM $QueryString";
}
- $QueryString .= $self->_OrderClause;
+ $QueryString .= ' ' . $self->_GroupClause . ' ';
+
+ $QueryString .= ' ' . $self->_OrderClause . ' ';
$self->_ApplyLimits(\$QueryString);
@@ -351,9 +403,7 @@ sub BuildSelectQuery {
}
-# }}}
-# {{{ BuildSelectCountQuery
=head2 BuildSelectCountQuery
@@ -383,11 +433,8 @@ sub BuildSelectCountQuery {
return ($QueryString);
}
-# }}}
-# {{{ Methods dealing traversing rows within the found set
-# {{{ sub Next
=head2 Next
@@ -397,7 +444,7 @@ such that the following call to Next will start over with the first item retriev
=cut
-*next = \&Next;
+
sub Next {
my $self = shift;
@@ -405,9 +452,9 @@ sub Next {
return (undef) unless ( $self->_isLimited );
- $self->_DoSearch() if ( $self->{'must_redo_search'} != 0 );
+ $self->_DoSearch() if $self->{'must_redo_search'};
- if ( $self->{'itemscount'} < $self->{'rows'} ) { #return the next item
+ if ( $self->{'itemscount'} < $self->_RecordCount ) { #return the next item
my $item = ( $self->{'items'}[ $self->{'itemscount'} ] );
$self->{'itemscount'}++;
return ($item);
@@ -418,9 +465,7 @@ sub Next {
}
}
-# }}}
-# {{{ sub GotoFirstItem
=head2 GotoFirstItem
@@ -430,15 +475,13 @@ through the result set.
=cut
-*goto_first_item = \&GotoFirstItem;
+
sub GotoFirstItem {
my $self = shift;
$self->GotoItem(0);
}
-# }}}
-# {{{ sub GotoItem
=head2 GotoItem
@@ -455,9 +498,7 @@ sub GotoItem {
$self->{'itemscount'} = $item;
}
-# }}}
-# {{{ sub First
=head2 First
@@ -471,9 +512,7 @@ sub First {
return ( $self->Next );
}
-# }}}
-# {{{ sub Last
=head2 Last
@@ -487,9 +526,7 @@ sub Last {
return ( $self->Next );
}
-# }}}
-# {{{ ItemsArrayRef
=head2 ItemsArrayRef
@@ -511,11 +548,8 @@ sub ItemsArrayRef {
return ( $self->{'items'} || [] );
}
-# }}}
-# }}}
-# {{{ sub NewItem
=head2 NewItem
@@ -531,9 +565,7 @@ sub NewItem {
"DBIx::SearchBuilder needs to be subclassed. you can't use it directly.\n";
}
-# }}}
-# {{{ sub RedoSearch
=head2 RedoSearch
@@ -547,11 +579,8 @@ sub RedoSearch {
$self->{'must_redo_search'} = 1;
}
-# }}}
-# {{{ Routines dealing with Restrictions (where subclauses)
-# {{{ sub UnLimit
=head2 UnLimit
@@ -565,9 +594,7 @@ sub UnLimit {
$self->_isLimited(-1);
}
-# }}}
-# {{{ sub Limit
=head2 Limit
@@ -618,6 +645,11 @@ STARTSWITH is like LIKE, except it only appends a % at the end of the string
ENDSWITH is like LIKE, except it prepends a % to the beginning of the string
+=item "MATCHES"
+
+MATCHES is equivalent to the database's LIKE -- that is, it's actually LIKE, but
+doesn't surround the string in % signs as LIKE does.
+
=back
=item ENTRYAGGREGATOR
@@ -636,7 +668,7 @@ this search case sensitive
sub Limit {
my $self = shift;
my %args = (
- TABLE => $self->{'table'},
+ TABLE => $self->Table,
FIELD => undef,
VALUE => undef,
ALIAS => undef,
@@ -667,7 +699,9 @@ sub Limit {
elsif ( $args{'OPERATOR'} =~ /ENDSWITH/i ) {
$args{'VALUE'} = "%" . $args{'VALUE'};
$args{'OPERATOR'} = "LIKE";
- }
+ }
+
+ $args{'OPERATOR'} =~ s/MATCHES/LIKE/i; # MATCHES becomes LIKE, with no % stuff
#if we're explicitly told not to to quote the value or
# we're doing an IS or IS NOT (null), don't quote the operator.
@@ -703,9 +737,7 @@ sub Limit {
}
}
-# }}}
-# {{{ sub ShowRestrictions
=head2 ShowRestrictions
@@ -723,9 +755,7 @@ sub ShowRestrictions {
}
-# }}}
-# {{{ sub ImportRestrictions
=head2 ImportRestrictions
@@ -741,13 +771,11 @@ sub ImportRestrictions {
$self->{'where_clause'} = shift;
}
-# }}}
-# {{{ sub _GenericRestriction
sub _GenericRestriction {
my $self = shift;
- my %args = ( TABLE => $self->{'table'},
+ my %args = ( TABLE => $self->Table,
FIELD => undef,
VALUE => undef,
ALIAS => undef,
@@ -777,7 +805,7 @@ sub _GenericRestriction {
unless ( $args{'ALIAS'} ) {
#if the table we're looking at is the same as the main table
- if ( $args{'TABLE'} eq $self->{'table'} ) {
+ if ( $args{'TABLE'} eq $self->Table ) {
# TODO this code assumes no self joins on that table.
# if someone can name a case where we'd want to do that,
@@ -862,9 +890,7 @@ sub _GenericRestriction {
}
-# }}}
-# {{{ Parentheses Control
sub _OpenParen {
my ( $self, $clause ) = @_;
$self->{_open_parens}{$clause}++;
@@ -882,9 +908,7 @@ sub _CloseParen {
}
}
-# }}}
-# {{{ sub _AddRestriction
sub _AddSubClause {
my $self = shift;
my $clauseid = shift;
@@ -894,9 +918,7 @@ sub _AddSubClause {
}
-# }}}
-# {{{ sub _WhereClause
sub _WhereClause {
my $self = shift;
@@ -926,9 +948,7 @@ sub _WhereClause {
}
-# }}}
-# {{{ sub _CompileGenericRestrictions
#Compile the restrictions to a WHERE Clause
@@ -948,13 +968,9 @@ sub _CompileGenericRestrictions {
}
}
-# }}}
-# }}}
-# {{{ Routines dealing with ordering
-# {{{ sub OrderBy
=head2 Orderby PARAMHASH
@@ -1028,9 +1044,7 @@ sub OrderByCols {
$self->RedoSearch();
}
-# }}}
-# {{{ sub _OrderClause
=head2 _OrderClause
@@ -1041,19 +1055,13 @@ returns the ORDER BY clause for the search.
sub _OrderClause {
my $self = shift;
- unless ( defined $self->{'order_clause'} ) {
- return "";
- }
+ return '' unless $self->{'order_clause'};
return ($self->{'order_clause'});
}
-# }}}
-# }}}
-# {{{ Routines dealing with grouping
-# {{{ GroupBy (OBSOLETE)
=head2 GroupBy (DEPRECATED)
@@ -1061,11 +1069,9 @@ Alias for the GroupByCols method.
=cut
-sub GroupBy { (shift)->GroupByCols( @_) }
+sub GroupBy { (shift)->GroupByCols( @_ ) }
-# }}}
-# {{{ GroupByCols
=head2 GroupByCols ARRAY_OF_HASHES
@@ -1106,9 +1112,7 @@ sub GroupByCols {
}
$self->RedoSearch();
}
-# }}}
-# {{{ _GroupClause
=head2 _GroupClause
@@ -1119,19 +1123,13 @@ Private function to return the "GROUP BY" clause for this query.
sub _GroupClause {
my $self = shift;
- unless ( defined $self->{'group_clause'} ) {
- return "";
- }
+ return '' unless $self->{'group_clause'};
return ($self->{'group_clause'});
}
-# }}}
-# }}}
-# {{{ routines dealing with table aliases and linking tables
-# {{{ sub NewAlias
=head2 NewAlias
@@ -1154,9 +1152,7 @@ sub NewAlias {
return $alias;
}
-# }}}
-# {{{ sub _GetAlias
# _GetAlias is a private function which takes an tablename and
# returns a new alias for that table without adding something
@@ -1174,9 +1170,7 @@ sub _GetAlias {
}
-# }}}
-# {{{ sub Join
=head2 Join
@@ -1214,34 +1208,24 @@ sub Join {
}
-# }}}
-# }}}
-# {{{ Deal with 'pages' of results'
-# {{{ sub NextPage
sub NextPage {
my $self = shift;
$self->FirstRow( $self->FirstRow + $self->RowsPerPage );
}
-# }}}
-# {{{ sub FirstPage
sub FirstPage {
my $self = shift;
$self->FirstRow(1);
}
-# }}}
-# {{{ sub LastPage
-# }}}
-# {{{ sub PrevPage
sub PrevPage {
my $self = shift;
@@ -1253,9 +1237,7 @@ sub PrevPage {
}
}
-# }}}
-# {{{ sub GotoPage
sub GotoPage {
my $self = shift;
@@ -1268,9 +1250,7 @@ sub GotoPage {
}
}
-# }}}
-# {{{ sub RowsPerPage
=head2 RowsPerPage
@@ -1287,9 +1267,7 @@ sub RowsPerPage {
return ( $self->{'show_rows'} );
}
-# }}}
-# {{{ sub FirstRow
=head2 FirstRow
@@ -1315,13 +1293,9 @@ sub FirstRow {
return ( $self->{'first_row'} );
}
-# }}}
-# }}}
-# {{{ Public utility methods
-# {{{ sub _ItemsCounter
=head2 _ItemsCounter
@@ -1334,9 +1308,7 @@ sub _ItemsCounter {
return $self->{'itemscount'};
}
-# }}}
-# {{{ sub Count
=head2 Count
@@ -1345,7 +1317,7 @@ Returns the number of records in the set.
=cut
-*count = \&Count;
+
sub Count {
my $self = shift;
@@ -1367,13 +1339,11 @@ sub Count {
# If we have loaded everything from the DB we have an
# accurate count already.
else {
- return ( $self->{'rows'} );
+ return $self->_RecordCount;
}
}
-# }}}
-# {{{ sub CountAll
=head2 CountAll
@@ -1422,14 +1392,12 @@ sub CountAll {
# If we have loaded everything from the DB we have an
# accurate count already.
else {
- return ( $self->{'rows'} );
+ return $self->_RecordCount;
}
}
-# }}}
-# {{{ sub IsLast
=head2 IsLast
@@ -1440,17 +1408,17 @@ Returns true if the current row is the last record in the set.
sub IsLast {
my $self = shift;
+ return undef unless $self->Count;
+
if ( $self->_ItemsCounter == $self->Count ) {
return (1);
}
else {
- return (undef);
+ return (0);
}
}
-# }}}
-# {{{ sub DEBUG
sub DEBUG {
my $self = shift;
@@ -1460,14 +1428,11 @@ sub DEBUG {
return ( $self->{'DEBUG'} );
}
-# }}}
-# }}}
-# {{{ Column
=head2 Column { FIELD => undef }
@@ -1493,7 +1458,7 @@ sub Column {
$alias;
}
else {
- $self->{table};
+ $self->Table;
}
};
@@ -1516,14 +1481,12 @@ sub Column {
}
my $column = "col" . @{ $self->{columns} ||= [] };
- $column = $args{FIELD} if $table eq $self->{table} and !$args{ALIAS};
+ $column = $args{FIELD} if $table eq $self->Table and !$args{ALIAS};
push @{ $self->{columns} }, "$name AS \L$column";
return $column;
}
-# }}}
-# {{{ Columns
=head2 Columns LIST
@@ -1537,12 +1500,10 @@ sub Columns {
$self->Column( FIELD => $_ ) for @_;
}
-# }}}
-# {{{ Fields
=head2 Fields TABLE
-
+
Return a list of fields in TABLE, lowercased.
TODO: Why are they lowercased?
@@ -1567,10 +1528,8 @@ sub Fields {
};
}
-# }}}
-# {{{ HasField
=head2 HasField { TABLE => undef, FIELD => undef }
@@ -1590,13 +1549,11 @@ sub HasField {
return grep { $_ eq $field } $self->Fields($table);
}
-# }}}
-# {{{ SetTable
=head2 Table [TABLE]
-If called with an arguemnt, sets this collection's table.
+If called with an argument, sets this collection's table.
Always returns this collection's table.
@@ -1614,19 +1571,33 @@ sub Table {
}
-# }}}
-
+if( eval { require capitalization } ) {
+ capitalization->unimport( __PACKAGE__ );
+}
1;
__END__
-# {{{ POD
+=head1 TESTING
+
+In order to test most of the features of C<DBIx::SearchBuilder>, you need
+to provide C<make test> with a test database. For each DBI driver that you
+would like to test, set the environment variables C<SB_TEST_FOO>, C<SB_TEST_FOO_USER>,
+and C<SB_TEST_FOO_PASS> to a database name, database username, and database password,
+where "FOO" is the driver name in all uppercase. You can test as many drivers
+as you like. (The appropriate C<DBD::> module needs to be installed in order for
+the test to work.) Note that the C<SQLite> driver will automatically be tested if C<DBD::Sqlite>
+is installed, using a temporary file as the database. For example:
+
+ SB_TEST_MYSQL=test SB_TEST_MYSQL_USER=root SB_TEST_MYSQL_PASS=foo \
+ SB_TEST_PG=test SB_TEST_PG_USER=postgres make test
+
=head1 AUTHOR
-Copyright (c) 2001-2004 Jesse Vincent, jesse@fsck.com.
+Copyright (c) 2001-2005 Jesse Vincent, jesse@fsck.com.
All rights reserved.
@@ -1640,7 +1611,6 @@ DBIx::SearchBuilder::Handle, DBIx::SearchBuilder::Record.
=cut
-# }}}
@@ -0,0 +1,19 @@
+package Example::Model::Address;
+
+use base qw/DBIx::SearchBuilder::Record/;
+
+# Class and instance method
+
+sub Table { "Addresses" }
+
+# Class and instance method
+
+sub Schema {
+ return {
+ Name => { TYPE => 'varchar', },
+ Phone => { TYPE => 'varchar', },
+ EmployeeId => { REFERENCES => 'Example::Model::Employee', },
+ }
+}
+
+1;
\ No newline at end of file
@@ -0,0 +1,14 @@
+package Example::Model::Employee;
+
+use base qw/DBIx::SearchBuilder::Record/;
+
+sub Table { "Employees" }
+
+sub Schema {
+ return {
+ Name => { TYPE => 'varchar', },
+ Dexterity => { TYPE => 'integer', },
+ }
+}
+
+1;
\ No newline at end of file
@@ -0,0 +1,58 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+# Note: this script does not actually *create* the tables;
+# however, it needs to connect to the database in order to
+# get the specific capabilities of your database (like type info).
+# CHANGE THIS TO FIT YOUR DATABASE:
+my @CONNECT_ARGS = (
+ Driver => 'Pg',
+ Database => 'test',
+ Host => 'localhost',
+ User => 'postgres',
+ Password => '',
+);
+
+use DBIx::SearchBuilder::Handle;
+use DBIx::SearchBuilder::SchemaGenerator;
+
+my $BaseClass;
+
+BEGIN {
+ unless (@ARGV) {
+ die <<USAGE;
+usage: $0 Base::Class [libpath ...]
+ This script will search \@INC (with the given paths added
+ to its beginning) for all classes beginning with Base::Class::,
+ which should be subclasses of DBIx::SearchBuilder::Record implementing
+ Schema and Table. It prints SQL to generate tables standard output.
+
+ While it does not actually create the tables, it needs to connect to your
+ database (for now, must be Pg or maybe mysql) in order to discover specific
+ capabilities of the target database. You should edit \@CONNECT_ARGS in this
+ script to provide an appropriate database driver, database name, host, user,
+ and password.
+USAGE
+ }
+ $BaseClass = shift;
+ unshift @INC, @ARGV;
+}
+
+use Module::Pluggable search_path => $BaseClass, sub_name => 'models', instantiate => 'new';
+
+my $handle = DBIx::SearchBuilder::Handle->new;
+
+$handle->Connect( @CONNECT_ARGS );
+
+my $SG = DBIx::SearchBuilder::SchemaGenerator->new($handle);
+
+die "Couldn't make SchemaGenerator" unless $SG;
+
+for my $model (__PACKAGE__->models) {
+ my $ret = $SG->AddModel($model);
+ $ret or die "couldn't add model $model: ".$ret->error_message;
+}
+
+print $SG->CreateTableSQLText;
@@ -0,0 +1,62 @@
+#line 1 "inc/Module/Install/AutoInstall.pm - /usr/local/share/perl/5.8.4/Module/Install/AutoInstall.pm"
+package Module::Install::AutoInstall;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+sub AutoInstall { $_[0] }
+
+sub run {
+ my $self = shift;
+ $self->auto_install_now(@_);
+}
+
+sub write {
+ my $self = shift;
+ $self->auto_install(@_);
+}
+
+sub auto_install {
+ my $self = shift;
+ return if $self->{done}++;
+
+# ExtUtils::AutoInstall Bootstrap Code, version 7.
+AUTO:{my$p='ExtUtils::AutoInstall';my$v=0.49;$p->VERSION||0>=$v
+or+eval"use $p $v;1"or+do{my$e=$ENV{PERL_EXTUTILS_AUTOINSTALL};
+(!defined($e)||$e!~m/--(?:default|skip|testonly)/and-t STDIN or
+eval"use ExtUtils::MakeMaker;WriteMakefile(PREREQ_PM=>{'$p',$v}
+);1"and exit)and print"==> $p $v required. Install it from CP".
+"AN? [Y/n] "and<STDIN>!~/^n/i and print"*** Installing $p\n"and
+do{if (eval '$>' and lc(`sudo -V`) =~ /version/){system('sudo',
+$^X,"-MCPANPLUS","-e","CPANPLUS::install $p");eval"use $p $v;1"
+||system('sudo', $^X, "-MCPAN", "-e", "CPAN::install $p")}eval{
+require CPANPLUS;CPANPLUS::install$p};eval"use $p $v;1"or eval{
+require CPAN;CPAN::install$p};eval"use $p $v;1"||die"*** Please
+manually install $p $v from cpan.org first...\n"}}}
+
+ # Flatten array of arrays into a single array
+ my @core = map @$_, map @$_, grep ref,
+ $self->build_requires, $self->requires;
+
+ while ( @core and @_ > 1 and $_[0] =~ /^-\w+$/ ) {
+ push @core, splice(@_, 0, 2);
+ }
+
+ ExtUtils::AutoInstall->import(
+ (@core ? (-core => \@core) : ()), @_, $self->features
+ );
+
+ $self->makemaker_args( ExtUtils::AutoInstall::_make_args() );
+
+ my $class = ref($self);
+ $self->postamble(
+ "# --- $class section:\n" .
+ ExtUtils::AutoInstall::postamble()
+ );
+}
+
+sub auto_install_now {
+ my $self = shift;
+ $self->auto_install;
+ ExtUtils::AutoInstall::do_install();
+}
+
+1;
@@ -4,17 +4,15 @@ use strict;
use Test::More;
BEGIN { require "t/utils.pl" }
-our (@SupportedDrivers);
+our (@AvailableDrivers);
-my $total = scalar(@SupportedDrivers) * 4;
+use constant TESTS_PER_DRIVER => 4;
+
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
plan tests => $total;
-foreach my $d ( @SupportedDrivers ) {
+foreach my $d ( @AvailableDrivers ) {
SKIP: {
- eval "require DBD::$d";
- if( $@ ) {
- skip "DBD::$d is not installed", 4;
- }
use_ok('DBIx::SearchBuilder::Handle::'. $d);
my $handle = get_handle( $d );
isa_ok($handle, 'DBIx::SearchBuilder::Handle');
@@ -0,0 +1,40 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More;
+BEGIN { require "t/utils.pl" }
+
+use vars qw(@SPEC_METHODS @MODULES);
+my @SPEC_METHODS = qw(AUTOLOAD DESTROY CLONE);
+my @MODULES = qw(DBIx::SearchBuilder DBIx::SearchBuilder::Record);
+
+if( not eval { require Devel::Symdump } ) {
+ plan skip_all => 'Devel::Symdump is not installed';
+} elsif( not eval { require capitalization } ) {
+ plan skip_all => 'capitalization pragma is not installed';
+} else {
+ plan tests => scalar @MODULES;
+}
+
+foreach my $mod( @MODULES ) {
+ eval "require $mod";
+ my $dump = Devel::Symdump->new($mod);
+ my @methods = ();
+ foreach my $method (map { s/^\Q$mod\E:://; $_ } $dump->functions) {
+ push @methods, $method;
+
+ my $nocap = nocap( $method );
+ push @methods, $nocap if $nocap ne $method;
+ }
+ can_ok( $mod, @methods );
+}
+
+sub nocap
+{
+ my $method = shift;
+ return $method if grep( { $_ eq $method } @SPEC_METHODS );
+ $method =~ s/(?<=[a-z])([A-Z]+)/"_" . lc($1)/eg;
+ return lc($method);
+}
+
@@ -6,102 +6,201 @@ use warnings;
use File::Spec;
use Test::More;
BEGIN { require "t/utils.pl" }
+our (@AvailableDrivers);
-eval "use DBD::SQLite";
-if ($@) {
-plan skip_all => "DBD::SQLite required for testing database interaction"
-} else{
-plan tests => 30;
-}
+use constant TESTS_PER_DRIVER => 65;
+
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+plan tests => $total;
-my $handle = get_handle('SQLite');
-$handle->Connect( Driver => 'SQLite', Database => File::Spec->catfile(File::Spec->tmpdir(), "sb-test.$$"));
-isa_ok($handle->dbh, 'DBI::db');
+foreach my $d ( @AvailableDrivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp::Address', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
-my $ret = $handle->SimpleQuery(TestApp::Address->schema);
-isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back");
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+ my $ret = init_schema( 'TestApp::Address', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back");
-my $rec = TestApp::Address->new($handle);
-isa_ok($rec, 'DBIx::SearchBuilder::Record');
+ my $rec = TestApp::Address->new($handle);
+ isa_ok($rec, 'DBIx::SearchBuilder::Record');
# _Accessible testings
-is( $rec->_Accessible('id' => 'read'), 1, 'id is accessible for read' );
-is( $rec->_Accessible('id' => 'write'), undef, 'id is not accessible for write' );
-is( $rec->_Accessible('unexpected_field' => 'read'), undef, "field doesn't exist and can't be accessible for read" );
+ is( $rec->_Accessible('id' => 'read'), 1, 'id is accessible for read' );
+ is( $rec->_Accessible('id' => 'write'), undef, 'id is not accessible for write' );
+ is( $rec->_Accessible('id'), undef, "any field is not accessible in undefined mode" );
+ is( $rec->_Accessible('unexpected_field' => 'read'), undef, "field doesn't exist and can't be accessible for read" );
+ is_deeply( [sort($rec->ReadableAttributes)], [qw(EmployeeId Name Phone id)], 'readable attributes' );
+ is_deeply( [sort($rec->WritableAttributes)], [qw(EmployeeId Name Phone)], 'writable attributes' );
-can_ok($rec,'Create');
+ can_ok($rec,'Create');
-my ($id) = $rec->Create( Name => 'Jesse', Phone => '617 124 567');
-ok($id,"Created record ". $id);
-ok($rec->Load($id), "Loaded the record");
+ my ($id) = $rec->Create( Name => 'Jesse', Phone => '617 124 567');
+ ok($id,"Created record ". $id);
+ ok($rec->Load($id), "Loaded the record");
-is($rec->id, $id, "The record has its id");
-is ($rec->Name, 'Jesse', "The record's name is Jesse");
+ is($rec->id, $id, "The record has its id");
+ is ($rec->Name, 'Jesse', "The record's name is Jesse");
-my ($val, $msg) = $rec->SetName('Obra');
-ok($val, $msg) ;
-is($rec->Name, 'Obra', "We did actually change the name");
+ my ($val, $msg) = $rec->SetName('Obra');
+ ok($val, $msg) ;
+ is($rec->Name, 'Obra', "We did actually change the name");
# Validate immutability of the field id
-($val, $msg) = $rec->Setid( $rec->id + 1 );
-ok(!$val, $msg);
-is($msg, 'Immutable field', 'id is immutable field');
-is($rec->id, $id, "The record still has its id");
+ ($val, $msg) = $rec->Setid( $rec->id + 1 );
+ ok(!$val, $msg);
+ is($msg, 'Immutable field', 'id is immutable field');
+ is($rec->id, $id, "The record still has its id");
# Check some non existant field
-ok( !eval{ $rec->SomeUnexpectedField }, "The record has no 'SomeUnexpectedField'");
-{
- # test produce DBI warning
- local $SIG{__WARN__} = sub {return};
- is( $rec->_Value( 'SomeUnexpectedField' ), undef, "The record has no 'SomeUnexpectedField'");
-}
-($val, $msg) = $rec->SetSomeUnexpectedField( 'foo' );
-ok(!$val, $msg);
-is($msg, 'Nonexistant field?', "Field doesn't exist");
-($val, $msg) = $rec->_Set('SomeUnexpectedField', 'foo');
-ok(!$val, "$msg");
+ ok( !eval{ $rec->SomeUnexpectedField }, "The record has no 'SomeUnexpectedField'");
+ {
+ # test produce DBI warning
+ local $SIG{__WARN__} = sub {return};
+ is( $rec->_Value( 'SomeUnexpectedField' ), undef, "The record has no 'SomeUnexpectedField'");
+ }
+ ($val, $msg) = $rec->SetSomeUnexpectedField( 'foo' );
+ ok(!$val, $msg);
+ is($msg, 'Nonexistant field?', "Field doesn't exist");
+ ($val, $msg) = $rec->_Set('SomeUnexpectedField', 'foo');
+ ok(!$val, "$msg");
# Validate truncation on update
-($val,$msg) = $rec->SetName('1234567890123456789012345678901234567890');
-
-ok($val, $msg) ;
-
-is($rec->Name, '12345678901234', "Truncated on update");
-
+ ($val,$msg) = $rec->SetName('1234567890123456789012345678901234567890');
+ ok($val, $msg);
+ is($rec->Name, '12345678901234', "Truncated on update");
+ $val = $rec->TruncateValue(Phone => '12345678901234567890');
+ is($val, '123456789012345678', 'truncate by length attribute');
# Test unicode truncation:
-my $univalue = "這是個測試";
-
-($val,$msg) = $rec->SetName($univalue.$univalue);
-
-ok($val, $msg) ;
-
-is($rec->Name, '這是個測');
+ my $univalue = "這是個測試";
+ ($val,$msg) = $rec->SetName($univalue.$univalue);
+ ok($val, $msg) ;
+ is($rec->Name, '這是個測');
# make sure we do _not_ truncate things which should not be truncated
-($val,$msg) = $rec->SetEmployeeId('1234567890');
-
-ok($val, $msg) ;
-
-is($rec->EmployeeId, '1234567890', "Did not truncate id on create");
+ ($val,$msg) = $rec->SetEmployeeId('1234567890');
+ ok($val, $msg) ;
+ is($rec->EmployeeId, '1234567890', "Did not truncate id on create");
# make sure we do truncation on create
-my $newrec = TestApp::Address->new($handle);
-my $newid = $newrec->Create( Name => '1234567890123456789012345678901234567890',
- EmployeeId => '1234567890' );
-
-$newrec->Load($newid);
+ my $newrec = TestApp::Address->new($handle);
+ my $newid = $newrec->Create( Name => '1234567890123456789012345678901234567890',
+ EmployeeId => '1234567890' );
+
+ $newrec->Load($newid);
+
+ ok ($newid, "Created a new record");
+ is($newrec->Name, '12345678901234', "Truncated on create");
+ is($newrec->EmployeeId, '1234567890', "Did not truncate id on create");
+
+# no prefetch feature and _LoadFromSQL sub checks
+ $newrec = TestApp::Address->new($handle);
+ ($val, $msg) = $newrec->_LoadFromSQL('SELECT id FROM Address WHERE id = ?', $newid);
+ is($val, 1, 'found object');
+ is($newrec->Name, '12345678901234', "autoloaded not prefetched field");
+ is($newrec->EmployeeId, '1234567890', "autoloaded not prefetched field");
+
+# _LoadFromSQL and missing PK
+ $newrec = TestApp::Address->new($handle);
+ ($val, $msg) = $newrec->_LoadFromSQL('SELECT Name FROM Address WHERE Name = ?', '12345678901234');
+ is($val, 0, "didn't find object");
+ is($msg, "Missing a primary key?", "reason is missing PK");
+
+# _LoadFromSQL and not existant row
+ $newrec = TestApp::Address->new($handle);
+ ($val, $msg) = $newrec->_LoadFromSQL('SELECT id FROM Address WHERE id = ?', 0);
+ is($val, 0, "didn't find object");
+ is($msg, "Couldn't find row", "reason is wrong id");
+
+# _LoadFromSQL and wrong SQL
+ $newrec = TestApp::Address->new($handle);
+ {
+ local $SIG{__WARN__} = sub{return};
+ ($val, $msg) = $newrec->_LoadFromSQL('SELECT ...');
+ }
+ is($val, 0, "didn't find object");
+ is($msg, "Couldn't execute query", "reason is bad SQL");
+
+# test Load* methods
+ $newrec = TestApp::Address->new($handle);
+ $newrec->Load();
+ is( $newrec->id, undef, "can't load record with undef id");
+
+ $newrec = TestApp::Address->new($handle);
+ $newrec->LoadByCol( Name => '12345678901234' );
+ is( $newrec->id, $newid, "load record by 'Name' column value");
+
+# LoadByCol with operator
+ $newrec = TestApp::Address->new($handle);
+ $newrec->LoadByCol( Name => { value => '%45678%',
+ operator => 'LIKE' } );
+ is( $newrec->id, $newid, "load record by 'Name' with LIKE");
+
+# LoadByPrimaryKeys
+ $newrec = TestApp::Address->new($handle);
+ ($val, $msg) = $newrec->LoadByPrimaryKeys( id => $newid );
+ ok( $val, "load record by PK");
+ is( $newrec->id, $newid, "loaded correct record");
+ $newrec = TestApp::Address->new($handle);
+ ($val, $msg) = $newrec->LoadByPrimaryKeys( {id => $newid} );
+ ok( $val, "load record by PK");
+ is( $newrec->id, $newid, "loaded correct record" );
+ $newrec = TestApp::Address->new($handle);
+ ($val, $msg) = $newrec->LoadByPrimaryKeys( Phone => 'some' );
+ ok( !$val, "couldn't load, missing PK field");
+ is( $msg, "Missing PK field: 'id'", "right error message" );
+
+# LoadByCols and empty or NULL values
+ $rec = TestApp::Address->new($handle);
+ $id = $rec->Create( Name => 'Obra', Phone => undef );
+ ok( $id, "new record");
+ $rec = TestApp::Address->new($handle);
+ $rec->LoadByCols( Name => 'Obra', Phone => undef, EmployeeId => '' );
+ is( $rec->id, $id, "loaded record by empty value" );
+
+# __Set error paths
+ $rec = TestApp::Address->new($handle);
+ $rec->Load( $id );
+ $val = $rec->SetName( 'Obra' );
+ isa_ok( $val, 'Class::ReturnValue', "couldn't set same value, error returned");
+ is( ($val->as_array)[1], "That is already the current value", "correct error message" );
+ is( $rec->Name, 'Obra', "old value is still there");
+ $val = $rec->SetName( 'invalid' );
+ isa_ok( $val, 'Class::ReturnValue', "couldn't set invalid value, error returned");
+ is( ($val->as_array)[1], 'Illegal value for Name', "correct error message" );
+ is( $rec->Name, 'Obra', "old value is still there");
+# XXX TODO FIXME: this test cover current implementation that is broken //RUZ
+ $val = $rec->SetName( );
+ isa_ok( $val, 'Class::ReturnValue', "couldn't set empty/undef value, error returned");
+ is( ($val->as_array)[1], "No value passed to _Set", "correct error message" );
+ is( $rec->Name, 'Obra', "old value is still there");
+
+# deletes
+ $newrec = TestApp::Address->new($handle);
+ $newrec->Load( $newid );
+ is( $newrec->Delete, 1, 'successfuly delete record');
+ $newrec = TestApp::Address->new($handle);
+ $newrec->Load( $newid );
+ is( $newrec->id, undef, "record doesn't exist any more");
+
+ cleanup_schema( 'TestApp::Address', $handle );
+}} # SKIP, foreach blocks
-ok ($newid, "Created a new record");
-is($newrec->Name, '12345678901234', "Truncated on create");
-is($newrec->EmployeeId, '1234567890', "Did not truncate id on create");
+1;
@@ -116,6 +215,13 @@ sub _Init {
$self->_Handle($handle);
}
+sub ValidateName
+{
+ my ($self, $value) = @_;
+ return 0 if $value =~ /invalid/i;
+ return 1;
+}
+
sub _ClassAccessible {
{
@@ -125,7 +231,7 @@ sub _ClassAccessible {
Name =>
{read => 1, write => 1, type => 'varchar(14)', default => ''},
Phone =>
- {read => 1, write => 1, type => 'varchar(18)', default => ''},
+ {read => 1, write => 1, type => 'varchar(18)', length => 18, default => ''},
EmployeeId =>
{read => 1, write => 1, type => 'int(8)', default => ''},
@@ -133,8 +239,31 @@ sub _ClassAccessible {
}
+sub schema_mysql {
+<<EOF;
+CREATE TEMPORARY TABLE Address (
+ id integer AUTO_INCREMENT,
+ Name varchar(36),
+ Phone varchar(18),
+ EmployeeId int(8),
+ PRIMARY KEY (id))
+EOF
+
+}
+
+sub schema_pg {
+<<EOF;
+CREATE TEMPORARY TABLE Address (
+ id serial PRIMARY KEY,
+ Name varchar,
+ Phone varchar,
+ EmployeeId integer
+)
+EOF
+
+}
-sub schema {
+sub schema_sqlite {
<<EOF;
CREATE TABLE Address (
@@ -0,0 +1,283 @@
+#!/usr/bin/perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@AvailableDrivers);
+
+use constant TESTS_PER_DRIVER => 69;
+
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @AvailableDrivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back");
+
+ my $count_all = init_data( 'TestApp::User', $handle );
+ ok( $count_all, "init users data" );
+
+ my $users_obj = TestApp::Users->new( $handle );
+ isa_ok( $users_obj, 'DBIx::SearchBuilder' );
+ is( $users_obj->_Handle, $handle, "same handle as we used in constructor");
+
+# check that new object returns 0 records in any case
+ is( $users_obj->_RecordCount, 0, '_RecordCount returns 0 on not limited obj' );
+ is( $users_obj->Count, 0, 'Count returns 0 on not limited obj' );
+ is( $users_obj->IsLast, undef, 'IsLast returns undef on not limited obj after Count' );
+ is( $users_obj->First, undef, 'First returns undef on not limited obj' );
+ is( $users_obj->IsLast, undef, 'IsLast returns undef on not limited obj after First' );
+ is( $users_obj->Last, undef, 'Last returns undef on not limited obj' );
+ is( $users_obj->IsLast, undef, 'IsLast returns undef on not limited obj after Last' );
+ $users_obj->GotoFirstItem;
+ is( $users_obj->Next, undef, 'Next returns undef on not limited obj' );
+ is( $users_obj->IsLast, undef, 'IsLast returns undef on not limited obj after Next' );
+ # XXX TODO FIXME: may be this methods should be implemented
+ # $users_obj->GotoLastItem;
+ # is( $users_obj->Prev, undef, 'Prev returns undef on not limited obj' );
+ my $items_ref = $users_obj->ItemsArrayRef;
+ isa_ok( $items_ref, 'ARRAY', 'ItemsArrayRef always returns array reference' );
+ is_deeply( $items_ref, [], 'ItemsArrayRef returns [] on not limited obj' );
+
+# unlimit new object and check
+ $users_obj->UnLimit;
+ is( $users_obj->Count, $count_all, 'Count returns same number of records as was inserted' );
+ isa_ok( $users_obj->First, 'DBIx::SearchBuilder::Record', 'First returns record object' );
+ isa_ok( $users_obj->Last, 'DBIx::SearchBuilder::Record', 'Last returns record object' );
+ $users_obj->GotoFirstItem;
+ isa_ok( $users_obj->Next, 'DBIx::SearchBuilder::Record', 'Next returns record object' );
+ $items_ref = $users_obj->ItemsArrayRef;
+ isa_ok( $items_ref, 'ARRAY', 'ItemsArrayRef always returns array reference' );
+ is( scalar @{$items_ref}, $count_all, 'ItemsArrayRef returns same number of records as was inserted' );
+ $users_obj->RedoSearch;
+ $items_ref = $users_obj->ItemsArrayRef;
+ isa_ok( $items_ref, 'ARRAY', 'ItemsArrayRef always returns array reference' );
+ is( scalar @{$items_ref}, $count_all, 'ItemsArrayRef returns same number of records as was inserted' );
+
+# try to use $users_obj for all tests, after each call to CleanSlate it should look like new obj.
+# and test $obj->new syntax
+ my $clean_obj = $users_obj->new( $handle );
+ isa_ok( $clean_obj, 'DBIx::SearchBuilder' );
+
+# basic limits
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Login', VALUE => 'obra' );
+ is( $users_obj->Count, 1, 'found one user with login obra' );
+ TODO: {
+ local $TODO = 'require discussion';
+ is( $users_obj->IsLast, undef, 'IsLast returns undef before we fetch any record' );
+ }
+ my $first_rec = $users_obj->First;
+ isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' );
+ is( $users_obj->IsLast, 1, '1 record in the collection then first rec is last');
+ is( $first_rec->Login, 'obra', 'login is correct' );
+ my $last_rec = $users_obj->Last;
+ is( $last_rec, $first_rec, 'Last returns same object as First' );
+ is( $users_obj->IsLast, 1, 'IsLast always returns 1 after Last call');
+ $users_obj->GotoFirstItem;
+ my $next_rec = $users_obj->Next;
+ is( $next_rec, $first_rec, 'Next returns same object as First' );
+ is( $users_obj->IsLast, 1, 'IsLast returns 1 after fetch first record with Next method');
+ is( $users_obj->Next, undef, 'only one record in the collection' );
+ TODO: {
+ local $TODO = 'require discussion';
+ is( $users_obj->IsLast, undef, 'Next returns undef, IsLast returns undef too');
+ }
+ $items_ref = $users_obj->ItemsArrayRef;
+ isa_ok( $items_ref, 'ARRAY', 'ItemsArrayRef always returns array reference' );
+ is( scalar @{$items_ref}, 1, 'ItemsArrayRef has only 1 record' );
+
+# similar basic limit, but with different OPERATORS and less Firs/Next/Last tests
+ # LIKE
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Name', OPERATOR => 'LIKE', VALUE => 'Glass' );
+ is( $users_obj->Count, 1, "found one user with 'Glass' in the name" );
+ $first_rec = $users_obj->First;
+ isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' );
+ is( $first_rec->Login, 'glasser', 'login is correct' );
+
+ # MATCHES
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Name', OPERATOR => 'MATCHES', VALUE => 'lass' );
+ is( $users_obj->Count, 0, "found no user matching 'lass' in the name" );
+
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Name', OPERATOR => 'MATCHES', VALUE => '%lass' );
+ is( $users_obj->Count, 0, "found no user matching '%lass' in the name" );
+
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Name', OPERATOR => 'MATCHES', VALUE => 'lass%' );
+ is( $users_obj->Count, 0, "found no user matching 'lass%' in the name" );
+
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Name', OPERATOR => 'MATCHES', VALUE => '%lass%' );
+ is( $users_obj->Count, 1, "found one user matching '%lass%' in the name" );
+ $first_rec = $users_obj->First;
+ isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' );
+ is( $first_rec->Login, 'glasser', 'login is correct' );
+
+ # STARTSWITH
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Name', OPERATOR => 'STARTSWITH', VALUE => 'Ruslan' );
+ is( $users_obj->Count, 1, "found one user who name starts with 'Ruslan'" );
+ $first_rec = $users_obj->First;
+ isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' );
+ is( $first_rec->Login, 'cubic', 'login is correct' );
+
+ # ENDSWITH
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Name', OPERATOR => 'ENDSWITH', VALUE => 'Tang' );
+ is( $users_obj->Count, 1, "found one user who name ends with 'Tang'" );
+ $first_rec = $users_obj->First;
+ isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' );
+ is( $first_rec->Login, 'autrijus', 'login is correct' );
+
+ # IS NULL
+ # XXX TODO FIXME: FIELD => undef should be handled as NULL
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'IS', VALUE => 'NULL' );
+ is( $users_obj->Count, 2, "found 2 users who has unknown phone number" );
+
+ # IS NOT NULL
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'IS NOT', VALUE => 'NULL', QOUTEVALUE => 0 );
+ is( $users_obj->Count, $count_all - 2, "found users who has phone number filled" );
+
+ # ORDER BY / GROUP BY
+ $users_obj->CleanSlate;
+ is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object');
+ $users_obj->UnLimit;
+ $users_obj->GroupByCols({FIELD => 'Login'});
+ $users_obj->OrderBy(FIELD => 'Login', ORDER => 'desc');
+ $users_obj->Column(FIELD => 'Login');
+ is( $users_obj->Count, $count_all, "group by / order by finds right amount");
+ $first_rec = $users_obj->First;
+ isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' );
+ is( $first_rec->Login, 'obra', 'login is correct' );
+
+ cleanup_schema( 'TestApp', $handle );
+}} # SKIP, foreach blocks
+
+1;
+
+package TestApp;
+
+sub schema_mysql {
+<<EOF;
+CREATE TEMPORARY TABLE Users (
+ id integer AUTO_INCREMENT,
+ Login varchar(18) NOT NULL,
+ Name varchar(36),
+ Phone varchar(18),
+ PRIMARY KEY (id))
+EOF
+
+}
+
+sub schema_pg {
+<<EOF;
+CREATE TEMPORARY TABLE Users (
+ id serial PRIMARY KEY,
+ Login varchar(18) NOT NULL,
+ Name varchar(36),
+ Phone varchar(18)
+)
+EOF
+
+}
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE TABLE Users (
+ id integer primary key,
+ Login varchar(18) NOT NULL,
+ Name varchar(36),
+ Phone varchar(18))
+EOF
+
+}
+
+
+1;
+
+package TestApp::User;
+
+use base qw/DBIx::SearchBuilder::Record/;
+
+sub _Init {
+ my $self = shift;
+ my $handle = shift;
+ $self->Table('Users');
+ $self->_Handle($handle);
+}
+
+sub _ClassAccessible {
+ {
+ id =>
+ {read => 1, type => 'int(11)' },
+ Login =>
+ {read => 1, write => 1, type => 'varchar(18)' },
+ Name =>
+ {read => 1, write => 1, type => 'varchar(36)' },
+ Phone =>
+ {read => 1, write => 1, type => 'varchar(18)', default => ''},
+ }
+}
+
+sub init_data {
+ return (
+ [ 'Login', 'Name', 'Phone' ],
+ [ 'cubic', 'Ruslan U. Zakirov', '+7-903-264-XX-XX' ],
+ [ 'obra', 'Jesse Vincent', undef ],
+ [ 'glasser', 'David Glasser', undef ],
+ [ 'autrijus', 'Autrijus Tang', '+X-XXX-XXX-XX-XX' ],
+ );
+}
+
+1;
+
+package TestApp::Users;
+
+# use TestApp::User;
+use base qw/DBIx::SearchBuilder/;
+
+sub _Init {
+ my $self = shift;
+ $self->SUPER::_Init( Handle => shift );
+ $self->Table('Users');
+}
+
+sub NewItem
+{
+ my $self = shift;
+ return TestApp::User->new( $self->_Handle );
+}
+
+1;
+
@@ -4,44 +4,61 @@
use strict;
use warnings;
use File::Spec;
+use Test::More;
BEGIN { require "t/utils.pl" }
+our (@AvailableDrivers);
-use Test::More;
-eval "use DBD::SQLite";
-if ($@) {
-plan skip_all => "DBD::SQLite required for testing database interaction"
-} else{
-plan tests => 9;
-}
-my $handle = get_handle('SQLite');
-$handle->Connect( Driver => 'SQLite', Database => File::Spec->catfile(File::Spec->tmpdir(), "sb-test.$$"));
-isa_ok($handle->dbh, 'DBI::db');
+use constant TESTS_PER_DRIVER => 11;
-foreach( @{ TestApp->schema } ) {
- my $ret = $handle->SimpleQuery($_);
- isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back");
-}
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+foreach my $d ( @AvailableDrivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
-my $emp = TestApp::Employee->new($handle);
-my $e_id = $emp->Create( Name => 'RUZ' );
-ok($e_id, "Got an ide for the new emplyee");
-my $phone = TestApp::Phone->new($handle);
-isa_ok( $phone, 'TestApp::Phone', "it's atestapp::phone");
-my $p_id = $phone->Create( Employee => $e_id, Phone => '+7(903)264-03-51');
-# XXX: test fails if next string is commented
-is($p_id, 1, "Loaded record $p_id");
-$phone->Load( $p_id );
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
-my $obj = $phone->EmployeeObj($handle);
-ok($obj, "Employee #$e_id has phone #$p_id");
-is($obj->id, $e_id);
-is($obj->Name, 'RUZ');
+ my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back");
+
+ my $emp = TestApp::Employee->new($handle);
+ my $e_id = $emp->Create( Name => 'RUZ' );
+ ok($e_id, "Got an ide for the new emplyee");
+ my $phone = TestApp::Phone->new($handle);
+ isa_ok( $phone, 'TestApp::Phone', "it's atestapp::phone");
+ my $p_id = $phone->Create( Employee => $e_id, Phone => '+7(903)264-03-51');
+ # XXX: test fails if next string is commented
+ is($p_id, 1, "Loaded record $p_id");
+ $phone->Load( $p_id );
+
+ my $obj = $phone->EmployeeObj($handle);
+ ok($obj, "Employee #$e_id has phone #$p_id");
+ isa_ok( $obj, 'TestApp::Employee');
+ is($obj->id, $e_id);
+ is($obj->Name, 'RUZ');
+
+ # tests for no object mapping
+ my ($state, $msg) = $phone->ValueObj($handle);
+ ok(!$state, "State is false");
+ is( $msg, 'No object mapping for field', 'Error message is correct');
+
+ cleanup_schema( 'TestApp', $handle );
+}} # SKIP, foreach blocks
+
+1;
package TestApp;
-sub schema {
+sub schema_sqlite {
[
q{
CREATE TABLE Employees (
@@ -55,7 +72,36 @@ CREATE TABLE Phones (
Phone varchar(18)
) }
]
+}
+sub schema_mysql {
+[ q{
+CREATE TEMPORARY TABLE Employees (
+ id integer AUTO_INCREMENT primary key,
+ Name varchar(36)
+)
+}, q{
+CREATE TEMPORARY TABLE Phones (
+ id integer AUTO_INCREMENT primary key,
+ Employee integer NOT NULL,
+ Phone varchar(18)
+)
+} ]
+}
+
+sub schema_pg {
+[ q{
+CREATE TEMPORARY TABLE Employees (
+ id serial PRIMARY KEY,
+ Name varchar
+)
+}, q{
+CREATE TEMPORARY TABLE Phones (
+ id serial PRIMARY KEY,
+ Employee integer references Employees(id),
+ Phone varchar
+)
+} ]
}
package TestApp::Employee;
@@ -0,0 +1,35 @@
+#!/usr/bin/perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+use DBIx::SearchBuilder::Handle;
+
+BEGIN { require "t/utils.pl" }
+our (@AvailableDrivers);
+
+use constant TESTS_PER_DRIVER => 4;
+
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @AvailableDrivers ) {
+SKIP: {
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = DBIx::SearchBuilder::Handle->new;
+ ok($handle, "Made a generic handle");
+
+ is(ref $handle, 'DBIx::SearchBuilder::Handle', "It's really generic");
+
+ connect_handle_with_driver( $handle, $d );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ isa_ok($handle, "DBIx::SearchBuilder::Handle::$d", "Specialized Handle")
+}} # SKIP, foreach blocks
+
+1;
@@ -0,0 +1,111 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use constant TESTS_PER_DRIVER => 14;
+our @AvailableDrivers;
+
+BEGIN {
+ require("t/utils.pl");
+ my $total = 3 + scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+ if( not eval { require DBIx::DBSchema } ) {
+ plan skip_all => "DBIx::DBSchema not installed";
+ } else {
+ plan tests => $total;
+ }
+}
+
+BEGIN {
+ use_ok("DBIx::SearchBuilder::SchemaGenerator");
+ use_ok("DBIx::SearchBuilder::Handle");
+}
+
+require_ok("t/testmodels.pl");
+
+foreach my $d ( @AvailableDrivers ) {
+ SKIP: {
+ unless ($d eq 'Pg') {
+ skip "first goal is to work on Pg", TESTS_PER_DRIVER;
+ }
+
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver $d", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle, "DBIx::SearchBuilder::Handle::$d");
+ isa_ok($handle->dbh, 'DBI::db');
+
+ my $SG = DBIx::SearchBuilder::SchemaGenerator->new($handle);
+
+ isa_ok($SG, 'DBIx::SearchBuilder::SchemaGenerator');
+
+ isa_ok($SG->_db_schema, 'DBIx::DBSchema');
+
+ is($SG->CreateTableSQLText, '', "no tables means no sql");
+
+ my $ret = $SG->AddModel('Sample::This::Does::Not::Exist');
+
+ ok($ret == 0, "couldn't add model from nonexistent class");
+
+ like($ret->error_message, qr/Error making new object from Sample::This::Does::Not::Exist/,
+ "couldn't add model from nonexistent class");
+
+ is($SG->CreateTableSQLText, '', "no tables means no sql");
+
+ $ret = $SG->AddModel('Sample::Address');
+
+ ok($ret != 0, "added model from real class");
+
+ is_ignoring_space($SG->CreateTableSQLText, <<END_SCHEMA, "got the right schema");
+ CREATE TABLE Addresses (
+ id serial NOT NULL ,
+ EmployeeId integer ,
+ Name varchar DEFAULT 'Frank' ,
+ Phone varchar ,
+ PRIMARY KEY (id)
+ ) ;
+END_SCHEMA
+
+ my $employee = Sample::Employee->new;
+
+ isa_ok($employee, 'Sample::Employee');
+
+ $ret = $SG->AddModel($employee);
+
+ ok($ret != 0, "added model from an instantiated object");
+
+ is_ignoring_space($SG->CreateTableSQLText, <<END_SCHEMA, "got the right schema");
+ CREATE TABLE Addresses (
+ id serial NOT NULL ,
+ EmployeeId integer ,
+ Name varchar DEFAULT 'Frank' ,
+ Phone varchar ,
+ PRIMARY KEY (id)
+ ) ;
+ CREATE TABLE Employees (
+ id serial NOT NULL ,
+ Dexterity integer ,
+ Name varchar ,
+ PRIMARY KEY (id)
+ ) ;
+END_SCHEMA
+
+ my $manually_make_text = join ' ', map { "$_;" } $SG->CreateTableSQLStatements;
+ is_ignoring_space($SG->CreateTableSQLText, $manually_make_text, 'CreateTableSQLText is the statements in CreateTableSQLStatements')
+}}
+
+sub is_ignoring_space {
+ my $a = shift;
+ my $b = shift;
+
+ $a =~ s/^\s+//; $a =~ s/\s+$//; $a =~ s/\s+/ /g;
+ $b =~ s/^\s+//; $b =~ s/\s+$//; $b =~ s/\s+/ /g;
+
+ unshift @_, $b; unshift @_, $a;
+
+ goto &is;
+}
@@ -0,0 +1,292 @@
+#!/usr/bin/perl -w
+
+
+use strict;
+use warnings;
+use File::Spec;
+use Test::More;
+
+BEGIN { require "t/utils.pl" }
+our (@AvailableDrivers);
+
+use constant TESTS_PER_DRIVER => 63;
+
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @AvailableDrivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db', "Got handle for $d");
+
+ my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back");
+
+ my $emp = TestApp::Employee->new($handle);
+ my $e_id = $emp->Create( Name => 'RUZ' );
+ ok($e_id, "Got an id for the new employee: $e_id");
+ $emp->Load($e_id);
+ is($emp->id, $e_id);
+
+ my $phone_collection = $emp->Phones;
+ isa_ok($phone_collection, 'TestApp::PhoneCollection');
+
+ {
+ my $ph = $phone_collection->Next;
+ is($ph, undef, "No phones yet");
+ }
+
+ my $phone = TestApp::Phone->new($handle);
+ isa_ok( $phone, 'TestApp::Phone');
+ my $p_id = $phone->Create( Employee => $e_id, Phone => '+7(903)264-03-51');
+ is($p_id, 1, "Loaded phone $p_id");
+ $phone->Load( $p_id );
+
+ my $obj = $phone->Employee;
+
+ ok($obj, "Employee #$e_id has phone #$p_id");
+ isa_ok( $obj, 'TestApp::Employee');
+ is($obj->id, $e_id);
+ is($obj->Name, 'RUZ');
+
+ {
+ $phone_collection->RedoSearch;
+ my $ph = $phone_collection->Next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'found first phone');
+ is($ph->Phone, '+7(903)264-03-51');
+ is($phone_collection->Next, undef);
+ }
+
+ # tests for no object mapping
+ my $val = $phone->Phone;
+ is( $val, '+7(903)264-03-51', 'Non-object things still work');
+
+ my $emp2 = TestApp::Employee->new($handle);
+ isa_ok($emp2, 'TestApp::Employee');
+ my $e2_id = $emp2->Create( Name => 'Dave' );
+ ok($e2_id, "Got an id for the new employee: $e2_id");
+ $emp2->Load($e2_id);
+ is($emp2->id, $e2_id);
+
+ my $phone2_collection = $emp2->Phones;
+ isa_ok($phone2_collection, 'TestApp::PhoneCollection');
+
+ {
+ my $ph = $phone2_collection->Next;
+ is($ph, undef, "new emp has no phones");
+ }
+
+ {
+ $phone_collection->RedoSearch;
+ my $ph = $phone_collection->Next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'first emp still has phone');
+ is($ph->Phone, '+7(903)264-03-51');
+ is($phone_collection->Next, undef);
+ }
+
+ $phone->SetEmployee($e2_id);
+
+
+ my $emp3 = $phone->Employee;
+ isa_ok($emp3, 'TestApp::Employee');
+ is($emp3->Name, 'Dave', 'changed employees by ID');
+ is($emp3->id, $emp2->id);
+
+ {
+ $phone_collection->RedoSearch;
+ is($phone_collection->Next, undef, "first emp lost phone");
+ }
+
+ {
+ $phone2_collection->RedoSearch;
+ my $ph = $phone2_collection->Next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'new emp stole the phone');
+ is($ph->Phone, '+7(903)264-03-51');
+ is($phone2_collection->Next, undef);
+ }
+
+
+ $phone->SetEmployee($emp);
+
+ my $emp4 = $phone->Employee;
+ isa_ok($emp4, 'TestApp::Employee');
+ is($emp4->Name, 'RUZ', 'changed employees by obj');
+ is($emp4->id, $emp->id);
+
+ {
+ $phone2_collection->RedoSearch;
+ is($phone2_collection->Next, undef, "second emp lost phone");
+ }
+
+ {
+ $phone_collection->RedoSearch;
+ my $ph = $phone_collection->Next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'first emp stole the phone');
+ is($ph->Phone, '+7(903)264-03-51');
+ is($phone_collection->Next, undef);
+ }
+
+ my $phone2 = TestApp::Phone->new($handle);
+ isa_ok( $phone2, 'TestApp::Phone');
+ my $p2_id = $phone2->Create( Employee => $e_id, Phone => '123456');
+ ok($p2_id, "Loaded phone $p2_id");
+ $phone2->Load( $p2_id );
+
+ {
+ $phone_collection->RedoSearch;
+ my $ph = $phone_collection->Next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'still has this phone');
+ is($ph->Phone, '+7(903)264-03-51');
+ $ph = $phone_collection->Next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p2_id, 'now has that phone');
+ is($ph->Phone, '123456');
+ is($phone_collection->Next, undef);
+ }
+
+ # Test Create with obj as argument
+ my $phone3 = TestApp::Phone->new($handle);
+ isa_ok( $phone3, 'TestApp::Phone');
+ my $p3_id = $phone3->Create( Employee => $emp, Phone => '7890');
+ ok($p3_id, "Loaded phone $p3_id");
+ $phone3->Load( $p3_id );
+
+ {
+ $phone_collection->RedoSearch;
+ my $ph = $phone_collection->Next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p_id, 'still has this phone');
+ is($ph->Phone, '+7(903)264-03-51');
+ $ph = $phone_collection->Next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p2_id, 'still has that phone');
+ is($ph->Phone, '123456');
+ $ph = $phone_collection->Next;
+ isa_ok($ph, 'TestApp::Phone');
+ is($ph->id, $p3_id, 'even has this other phone');
+ is($ph->Phone, '7890');
+ is($phone_collection->Next, undef);
+ }
+
+
+
+ cleanup_schema( 'TestApp', $handle );
+}} # SKIP, foreach blocks
+
+1;
+
+
+package TestApp;
+sub schema_sqlite {
+[
+q{
+CREATE TABLE Employees (
+ id integer primary key,
+ Name varchar(36)
+)
+}, q{
+CREATE TABLE Phones (
+ id integer primary key,
+ Employee integer NOT NULL,
+ Phone varchar(18)
+) }
+]
+}
+
+sub schema_mysql {
+[ q{
+CREATE TEMPORARY TABLE Employees (
+ id integer AUTO_INCREMENT primary key,
+ Name varchar(36)
+)
+}, q{
+CREATE TEMPORARY TABLE Phones (
+ id integer AUTO_INCREMENT primary key,
+ Employee integer NOT NULL,
+ Phone varchar(18)
+)
+} ]
+}
+
+sub schema_pg {
+[ q{
+CREATE TEMPORARY TABLE Employees (
+ id serial PRIMARY KEY,
+ Name varchar
+)
+}, q{
+CREATE TEMPORARY TABLE Phones (
+ id serial PRIMARY KEY,
+ Employee integer references Employees(id),
+ Phone varchar
+)
+} ]
+}
+
+package TestApp::Employee;
+
+use base qw/DBIx::SearchBuilder::Record/;
+
+sub Table { 'Employees' }
+
+sub Schema {
+ return {
+ Name => { TYPE => 'varchar' },
+ Phones => { REFERENCES => 'TestApp::PhoneCollection', KEY => 'Employee' }
+ };
+}
+
+sub _Value {
+ my $self = shift;
+ my $x = ($self->__Value(@_));
+ return $x;
+}
+
+
+1;
+
+package TestApp::Phone;
+
+use base qw/DBIx::SearchBuilder::Record/;
+
+sub Table { 'Phones' }
+
+sub Schema {
+ return {
+ Employee => { REFERENCES => 'TestApp::Employee' },
+ Phone => { TYPE => 'varchar' },
+ }
+}
+
+package TestApp::PhoneCollection;
+
+use base qw/DBIx::SearchBuilder/;
+
+sub Table {
+ my $self = shift;
+ my $tab = $self->NewItem->Table();
+ return $tab;
+}
+
+sub NewItem {
+ my $self = shift;
+ my $class = 'TestApp::Phone';
+ return $class->new( $self->_Handle );
+
+}
+
+
+1;
@@ -0,0 +1,32 @@
+package Sample::Address;
+
+use base qw/DBIx::SearchBuilder::Record/;
+
+# Class and instance method
+
+sub Table { "Addresses" }
+
+# Class and instance method
+
+sub Schema {
+ return {
+ Name => { TYPE => 'varchar', DEFAULT => 'Frank', },
+ Phone => { TYPE => 'varchar', },
+ EmployeeId => { REFERENCES => 'Sample::Employee', },
+ }
+}
+
+package Sample::Employee;
+
+use base qw/DBIx::SearchBuilder::Record/;
+
+sub Table { "Employees" }
+
+sub Schema {
+ return {
+ Name => { TYPE => 'varchar', },
+ Dexterity => { TYPE => 'integer', },
+ }
+}
+
+1;
\ No newline at end of file
@@ -2,6 +2,14 @@
use strict;
+=head1 VARIABLES
+
+=head2 @SupportedDrivers
+
+Array of all supported DBD drivers.
+
+=cut
+
our @SupportedDrivers = qw(
Informix
mysql
@@ -13,6 +21,23 @@ our @SupportedDrivers = qw(
Sybase
);
+=head2 @AvailableDrivers
+
+Array that lists only drivers from supported list
+that user has installed.
+
+=cut
+
+our @AvailableDrivers = grep { eval "require DBD::". $_ } @SupportedDrivers;
+
+=head1 FUNCTIONS
+
+=head2 get_handle
+
+Returns new DB specific handle. Takes one argument DB C<$type>.
+Other arguments uses to construct handle.
+
+=cut
sub get_handle
{
@@ -21,11 +46,176 @@ sub get_handle
eval "require $class";
die $@ if $@;
my $handle;
- {
-# no strict 'refs';
- $handle = $class->new( @_ );
- }
+ $handle = $class->new( @_ );
return $handle;
}
+=head2 handle_to_driver
+
+Returns driver name which gets from C<$handle> object argument.
+
+=cut
+
+sub handle_to_driver
+{
+ my $driver = ref($_[0]);
+ $driver =~ s/^.*:://;
+ return $driver;
+}
+
+=head2 connect_handle
+
+Connects C<$handle> object to DB.
+
+=cut
+
+sub connect_handle
+{
+ my $call = "connect_". lc handle_to_driver( $_[0] );
+ return unless defined &$call;
+ goto &$call;
+}
+
+=head2 connect_handle_with_driver($handle, $driver)
+
+Connects C<$handle> using driver C<$driver>; can use this to test the
+magic that turns a C<DBIx::SearchBuilder::Handle> into a C<DBIx::SearchBuilder::Handle::Foo>
+on C<Connect>.
+
+=cut
+
+sub connect_handle_with_driver
+{
+ my $call = "connect_". lc $_[1];
+ return unless defined &$call;
+ @_ = $_[0];
+ goto &$call;
+}
+
+sub connect_sqlite
+{
+ my $handle = shift;
+ return $handle->Connect(
+ Driver => 'SQLite',
+ Database => File::Spec->catfile(File::Spec->tmpdir(), "sb-test.$$")
+ );
+}
+
+sub connect_mysql
+{
+ my $handle = shift;
+ return $handle->Connect(
+ Driver => 'mysql',
+ Database => $ENV{'SB_TEST_MYSQL'},
+ User => $ENV{'SB_TEST_MYSQL_USER'} || 'root',
+ Password => $ENV{'SB_TEST_MYSQL_PASS'} || '',
+ );
+}
+
+sub connect_pg
+{
+ my $handle = shift;
+ return $handle->Connect(
+ Driver => 'Pg',
+ Database => $ENV{'SB_TEST_PG'},
+ User => $ENV{'SB_TEST_PG_USER'} || 'postgres',
+ Password => $ENV{'SB_TEST_PG_PASS'} || '',
+ );
+}
+
+=head2 should_test
+
+Checks environment for C<SB_TEST_*> variables.
+Returns true if specified DB back-end should be tested.
+Takes one argument C<$driver> name.
+
+=cut
+
+sub should_test
+{
+ my $driver = shift;
+ return 1 if lc $driver eq 'sqlite';
+ my $env = 'SB_TEST_'. uc $driver;
+ return $ENV{$env};
+}
+
+=head2 had_schema
+
+Returns true if C<$class> has schema for C<$driver>.
+
+=cut
+
+sub has_schema
+{
+ my ($class, $driver) = @_;
+ my $method = 'schema_'. lc $driver;
+ return UNIVERSAL::can( $class, $method );
+}
+
+=head2 init_schema
+
+Takes C<$class> and C<$handle> and inits schema by calling
+C<schema_$driver> method of the C<$class>.
+Returns last C<DBI::st> on success or last return value of the
+SimpleQuery method on error.
+
+=cut
+
+sub init_schema
+{
+ my ($class, $handle) = @_;
+ my $call = "schema_". lc handle_to_driver( $handle );
+ my $schema = $class->$call();
+ $schema = ref( $schema )? $schema : [$schema];
+ my $ret;
+ foreach my $query( @$schema ) {
+ $ret = $handle->SimpleQuery( $query );
+ return $ret unless UNIVERSAL::isa( $ret, 'DBI::st' );
+ }
+ return $ret;
+}
+
+=head2 cleanup_schema
+
+Takes C<$class> and C<$handle> and cleanup schema by calling
+C<cleanup_schema_$driver> method of the C<$class> if method exists.
+Always returns undef.
+
+=cut
+
+sub cleanup_schema
+{
+ my ($class, $handle) = @_;
+ my $call = "cleanup_schema_". lc handle_to_driver( $handle );
+ return unless UNIVERSAL::can( $class, $call );
+ my $schema = $class->$call();
+ $schema = ref( $schema )? $schema : [$schema];
+ foreach my $query( @$schema ) {
+ eval { $handle->SimpleQuery( $query ) };
+ }
+}
+
+=head2 init_data
+
+=cut
+
+sub init_data
+{
+ my ($class, $handle) = @_;
+ my @data = $class->init_data();
+ my @columns = @{ shift @data };
+ my $count = 0;
+ foreach my $values ( @data ) {
+ my %args;
+ for( my $i = 0; $i < @columns; $i++ ) {
+ $args{ $columns[$i] } = $values->[$i];
+ }
+ my $rec = $class->new( $handle );
+ my $id = $rec->Create( %args );
+ die "Couldn't create record" unless $id;
+ $count++;
+ }
+ return $count;
+}
+
1;