DBIx-SearchBuilder-1.71/000755 000765 000024 00000000000 14123431630 015605 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/inc/000755 000765 000024 00000000000 14123431630 016356 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/SIGNATURE000644 000765 000024 00000016145 14123431630 017100 0ustar00sunnavystaff000000 000000 This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.87. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: RIPEMD160 SHA256 cd49c62f0302b9b1526486dc4dc8d43e6a04bc9ea86baefe70accff48e88c38c .gitignore SHA256 5f5a7cbacd5200fb8f0b61950ea2dfea87f536d631f884b675ff74c8a742b4d3 Changes SHA256 457977379ca593a53defb3dcf9f0659c419cd940e3a049ab5c064086f241ad9c MANIFEST SHA256 a110ebefb19d0efc707aeec32222c884cba6cf924af8c52fcf8f117741c33eda META.yml SHA256 50c1d68019f4bdeaf6c77579293cca33f55b7cf1de14ed1d5aa347cd719fd316 Makefile.PL SHA256 6099782ac8ce2cd4d13b2760df715fe6f3f57ed97df76c18704888e2cf8b5934 README SHA256 5f8c1ab450da2f3ba8373cda64706ef8e240a52034c03d6e97787b24c518f498 ROADMAP SHA256 b7c61a9d0ba3656c954b520772a0f74a01792a5ca8d060131a2fb7eed42f2ae0 ex/Example/Model/Address.pm SHA256 f4921f5b2e770e12141d57980e5babc8b207455275b4796d0baa77d588f058f5 ex/Example/Model/Employee.pm SHA256 fa2ccffe62a0558135516c479c12d24259355eb0186cbf1b203b67009447503f ex/create_tables.pl SHA256 7fe8013fad8ecb0b9ef8bad3fd7287486c1c61c776f76beb7d9d24e06ee3ab44 inc/Module/AutoInstall.pm SHA256 67d139199c03b8bf8447a5a62f0d0b6dc1bd5bf6dbe04de6d21998c577823ed6 inc/Module/Install.pm SHA256 1e48ae2cb24e1d16193d476e735579dfcd0eefb3685921ad4736390df75d939b inc/Module/Install/AutoInstall.pm SHA256 6ebcc53a161dd5dc0aae69e4704575f2b00181901d768a82e26722a309cfdbe4 inc/Module/Install/Base.pm SHA256 d3f8c839d03fd21c197d05362dbb277cd7cadb15da6390d124b61e851f15146e inc/Module/Install/Can.pm SHA256 e9e72e18921c10c87bc4ea4c20af83e52015b9f5775d00ac64073042403717ca inc/Module/Install/Fetch.pm SHA256 a97bf661b739643c3adee064addf7a85f22e25e1bbffc137974cd8754ffa5c66 inc/Module/Install/Include.pm SHA256 a7a681bf2c9eee58a372cb642ffe42b0301d1200432ba8de9f7791cd1ecc9827 inc/Module/Install/Makefile.pm SHA256 aa887fa65a5eb6bbd1805706ce298b3f3cd55b353ecfd37aa7d35ae419331a49 inc/Module/Install/Metadata.pm SHA256 26b166ff62aacdb55317d1659f160aa4935097eea9810ea980e6d747206b5dc0 inc/Module/Install/Win32.pm SHA256 5f73a6851a91ea44e65b924f918743ad6e860620ad7a38a39d0295e0c5652a9f inc/Module/Install/WriteAll.pm SHA256 a70ed193abc6f4f731e3862c0d84f0fbe57d22815b080a53586aef3701bd11dc lib/DBIx/SearchBuilder.pm SHA256 5d46a740604b6a8c13f0673548457827c4bdfecd82b9e30f038c0c88edd3c2c8 lib/DBIx/SearchBuilder/Handle.pm SHA256 be06e5dfc29416c6ba4662bd6026da255c6e95585212ada188332531ed4a9e59 lib/DBIx/SearchBuilder/Handle/Informix.pm SHA256 0fe34f8a9d74c6642a6b0459cd6ea610d43b80b22029c14d1b96fb616889f232 lib/DBIx/SearchBuilder/Handle/ODBC.pm SHA256 df013753fd248146b602cb56354791441a890fd20b6496e88221300a4673a95a lib/DBIx/SearchBuilder/Handle/Oracle.pm SHA256 8b454830f1dae663acca2056c681863206898c7ae1e657d7f5276eff8632cdb8 lib/DBIx/SearchBuilder/Handle/Pg.pm SHA256 c2e6cb94e20c6a77db195f4a8fa118c0b22237cde042dfebe3c0f71cd8d37877 lib/DBIx/SearchBuilder/Handle/SQLite.pm SHA256 a4cffae1aebe895548b7708c33460c972b7986c3fa9b743448e8f7d3add2e4e2 lib/DBIx/SearchBuilder/Handle/Sybase.pm SHA256 3764c629cd16fcab0d6e5d78ee5c63ac694a3b423caf887d32a4036f0305617f lib/DBIx/SearchBuilder/Handle/mysql.pm SHA256 94d11f80606194b5541abfd0945e40c62d7da575da151db662e66ab8d91629ea lib/DBIx/SearchBuilder/Handle/mysqlPP.pm SHA256 108d3a9570e8ed48edfea21fbaa910a26d16e11a523e95ebf12d7fb1225d63e4 lib/DBIx/SearchBuilder/Record.pm SHA256 9150d02b5177d4118f4de4865946808ece1426e2c06583440277cf20ca8957f0 lib/DBIx/SearchBuilder/Record/Cachable.pm SHA256 ffb637ee5be966f4ebd46c78d2b5c63113392cd7d2d439647f6e419d28d2f739 lib/DBIx/SearchBuilder/SchemaGenerator.pm SHA256 4e2dbeeec6a5994b97a1a751c1a05d67077ed5a8c860c24dd2d9d2a3b92230a8 lib/DBIx/SearchBuilder/Union.pm SHA256 9cdcc19f586c1dba961a39cc85e8738bcdf39a3dc0b902c5af2e0e134b49b4b4 lib/DBIx/SearchBuilder/Unique.pm SHA256 f4298ca835eaf58766f495746abd6f6d6e8abf74320bbf0f60ab3084ee478792 lib/DBIx/SearchBuilder/Util.pm SHA256 bf5ba946412cd15148a599e1a6559a1161edcd4309f3fe151b533927bdeafc11 t/00.load.t SHA256 ef7b9c19814507d98043c4b634fad449020fc1babfb82dcf07a5e870302816db t/01basics.t SHA256 0f4f676f79565d56a6659213409d9ae0c0e93c21f9e93dbd282a7a651b7bdeeb t/01nocap_api.t SHA256 c6c411878e691fa8623758f1460f9020e33204763f1b9cab015e7f321301a106 t/01records.t SHA256 48d61fd2292cbb6c3d823ea4522601455ce881d6c954f97a191fb22dbe3f0a68 t/01searches.t SHA256 ea91908091ec0a6fc32f5ac955fa7e0875a76b6dc1e7268f2b394f57339afae9 t/02distinct_values.t SHA256 1a78577aca1cafd5ee57df9660c2cd0a03633fc559a5167ffc1dff0a2c6f3459 t/02null_order.t SHA256 964328a63844f6211b3974b3eed2c632ef359e6e47e273c0120bf5b1bcacf910 t/02order_outer.t SHA256 4a54bb52661d172b59f84161dbf58c4c3d4d4adbef4319c533009194bb76a9cc t/02records_cachable.t SHA256 92109d7e82b285b8b0b545594d0384c6188016df1cd7feb15166b53527b111dc t/02records_datetime.t SHA256 3e462daf68ff7c31e3071ba8aa04e1c3dbd6da7592bb3cb571c1b858b6856c14 t/02records_dt_interval.t SHA256 a6509ea68bf7de614ba1792b114cfc79e7cd7924a382c5b23655595867f1301b t/02records_integers.t SHA256 68e7d42b6bec45cc4ba467cf7984ea45ccac4eef820b7bd747c56bfff29f68cc t/02records_object.t SHA256 6b8da418723572d8690aef154f5f674a3c76621277230b1a5b800ef2a89a9385 t/02searches_function.t SHA256 51b88a796a18b488326dbf105e7bfc4c7b9c96cc50b6a6e1269ee15da4017dce t/02searches_joins.t SHA256 5ece6c29b1b486f9108aed888aa6b6f5f477e6168718b14022bf6cffe995485b t/03compatibility.t SHA256 2bcf623dae2d834aed39f7402025174c827580fc275347a831745452f95c271c t/03cud_from_select.t SHA256 cf1bf26bc170c882ba305ad395a47ffab602ba0b8cf2cb2fca644bff090dcd87 t/03rebless.t SHA256 08ce4071eafad525124d6b5adb72e7d3b11da977308e975146ad4262a05955ff t/03searches_bind.t SHA256 1139b234cf38bcbe6549e26d3583bd430eab308e5d49a67853e86666c34eae0a t/03transactions.t SHA256 751c1b02433499fb4d84bdcb5629b998092833b068b23c8d3f93f9f019aded42 t/03versions.t SHA256 7b601f8172ccfec55b01d68f500e9c5b97d6485f2a65f10ce212245db77b6c93 t/04mysql_identifier_quoting.t SHA256 6e2e6fc5baf627cd9c7704fcf8be04240994b63acddb566bb16f64ac422d1816 t/10schema.t SHA256 6f2ce317262fff8d922677b7909af986fb71e681e7dbca7e8195ed3f2aa0c4cf t/11schema_records.t SHA256 6af42d63bca8220421bf9afef387d3be19378799649d1fda3faf634073aded6f t/20set_edge_cases.t SHA256 b0db96e65e2b5300f140170b054f3b6c4bb171240b085f4d5e21f16f961bcac9 t/pod.t SHA256 9cc94435aee3fee6d9a9e028c7fb70050b3b80810b082f6c9bac2f2bd91c6b3d t/testmodels.pl SHA256 de3db4c37a49849d6c1a07dac4351b7d3a2520524c4792a5304c684c62667dc4 t/utils.pl -----BEGIN PGP SIGNATURE----- iQEzBAEBAwAdFiEExJs3Lyv4ShkBFmAnDfCig/6sgLIFAmFOM5gACgkQDfCig/6s gLJesggAuQNBhNOT5T5GXySAM5bD8h/vDEPYbAupwgviCBAeTZQq04mZTuP6KrQI eEV7rbHQw4jfmtJ+Ory+RObcJkVrRop+gezeWAuGeHqf/yE4tLflBQjYUCHSJFzo vm0W7EN2wfU5peNhz0rJQUPDgGwpko+ueksAmKpfNr76EHSeRYr2FnSzTpzPDikh mTWbvhy/VN5oVF1GcuqPCu8Q9L75gl/cA/8cuQsw835rCeVRfDkJqFVjp/eXfmFs Tj616jWQCy9y1Bh52qU5H0vWTe5O35jtB2YA7fWpWlLJ+n8osOAQhQjp/vWC6Qeb mVsJBZNkIUcVfK0ct9o3cfiYhqcIfw== =RUO2 -----END PGP SIGNATURE----- DBIx-SearchBuilder-1.71/ROADMAP000644 000765 000024 00000005227 13275205765 016640 0ustar00sunnavystaff000000 000000 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. DBIx-SearchBuilder-1.71/Changes000644 000765 000024 00000051340 14123431561 017106 0ustar00sunnavystaff000000 000000 Revision history for Perl extension DBIx::SearchBuilder. 1.71 2021-09-24 - Add dot to load utils in tests for perl 5.26+ 1.70 2021-09-24 - Enable queries processed with BuildSelectQuery and BuildSelectCountQuery to use bind variables 1.69 2021-01-20 - New option to quote tablenames in queries, enabled automatically for MySQL 8 - Updated tests for new MySQL 8 reserved words and tablename quoting 1.68 2020-07-06 - Avoid segmentation faults on disconnect on MariaDB 10.2+ 1.67 - Add ->QueryHint and ->QueryHintFormatted to collection API for Oracle 1.66 - No changes since 1.65_02 1.65_02 - Stop unilaterally disabling the "UTF8" flag before executing queries - Make ->Fields case-sensitive in the column names it returns, as well as in the table name it takes. 1.65_01 - Make ->Fields only lookup information on the table requested, not all fields, for performance. It also is now case-sensitive in table name. - Omit calls to ->Fields entirely for PostgreSQL 9.1 and above 1.65 2013-07-03 - Bug fix for DateTimeInterval extraction on Pg 1.64 2013-07-01 - No changes since 1.63_03. Simply a non-dev release of everything since 1.63. 1.63_03 2013-06-14 - warn when rollback and commit are mixed - Handle->NullsOrder - skip timezone tests on SQLite when tzinfo is not there - skip tests if mysql can not do timezones - DISTINCT argument in Join method - DISTINCT argument in Join and NewAlias - Reset the iterator position whenever a search is run - Return the correct record from ->Last instead of the first record - Document the caveat of using GotoItem with a non-zero N 1.63_02 2013-04-17 - _Set now can take undef as argument to mean default or NULL. Still may result in error if default is not defined and no_nulls is true for the column. If old behaviour is required set $record->{'no_undefs_in_set'} to true value. - FUNCTION argument is now allowed in Limit. Code to combine FUNCTION, ALIAS and FIELD was refactored and unified in one place - CombineFunctionWithField method. Used in Column, GroupBy and Limit. This change should be backwards compatible. - Handle->DateTimeIntervalFunction 1.63_01 2013-03-27 - IN and NOT IN operators in ->Limit method - Add an AdditionalColumn method to collections - Add an AS parameter to Column method in collections - Consistent query generation by sorting hash keys/values 1.63 2012-09-14 - joins_are_distinct hint to indicate that distinct is not required for the current set of joins. 1.62 2012-03-26 - Bind values were ignored in SimpleUpdateFromSelect 1.61 2011-09-16 - New methods in Handle for mass changes from select statements: InsertFromSelect, DeleteFromSelect and SimpleUpdateFromSelect - New methods in Handle for generation of date time related SQL 1.60 2011-09-15 - custom BuildDSN for Oracle - Database is treated as SID if SID is not provided - Build 'dbi:Oracle:' instead of 'dbi:Oracle:sid=' - changes in DBIx::SearchBuilder->Column method - complete documentation - support for empty FIELD argument - column naming fix when explicit ALIAS => 'main' passed 1.59 2010-11-19 - DBIx::SearchBuilder->DistinctFieldValues method 1.58 2010-10-20 - SIGNATURE fix - delete obsolete cvs metadata from a module 1.57 2010-09-04 - INCOMPATIBLE CHANGE: NextPage and PrevPage were adding rows from the previous page. Jesse claims that when he wrote this code, he was 20 years old and it seemed like a good idea at the time. - When logging queries, include full stack trace - support $sb->NewAlias( 'table' => 'LEFT' ); - allow join to depend on nothing - catch cases when there are more closing parens then should be - Oracle: Use ROW_NUMBER() to propagate row ordering from inside the DISTINCT - Various performance improvements through small internal refactorings - Implemented 'sub Fields' on Oracle - unify case insensitive characters to avoid using LOWER() in some cases - We now RedoSearch when RowsPerPage is changed - No longer RedoSearch if FirstRow is called, but is not actually changed - Document all paging functions and test them - handle LOWER() in redundant LEFT joins optimizer, for Oracle and may be Pg - Make debugging problems easier by passing errors back https://rt.cpan.org/Ticket/Display.html?id=55203 - fix Record->PrimaryKeys, field names in values hash are lc'ed https://rt.cpan.org/Ticket/Display.html?id=18280 - doc updates and cleanups 1.56 2009-07-17 - Don't use LOWER/ILIKE with dates, heuristic is used, but shouldn't harm other things - Don't apply DISTINCT on queries with group by, COUNT(DISTINCT x) is different and covered in Column method 1.55 2009-05-07 - Put test suite SQLite databases inside of tempdirs so they get garbage collected properly. Thanks to Andreas Koenig [rt.cpan.org #41322] - Allow ->Join to pre-existing collection object - Imlement and test SB::Handle::Fields - Pg can not guaranty order in the following queries: SELECT ... FROM (SELECT... ORDER BY ...) we use them to build distinct sets with ordering by columns in joined tables. Switched to group by instead of sub-selects. 1.54 2008-07-09 - When aborting transactions, we need to flush our cache, because SQLite is reusing the primary id for later inserts and the cache can otherwise become inconsistent. 1.53 2008-04-02 - Fix mysql version check in DistinctQuery function - Fix order by outer column on Oracle - Improve tests 1.52 2008-04-01 - Fix order by outer column on SQLite, mysql, adjust Pg. Add test that cover this. 1.51 2008-01-15 - Fix CountAll method when paging is enabled and data is in memory already 1.50 2007-11-23 - Oracle: Don't DISTINCT query when there is a group by clause - Fix a problem when we have more then two collections in a union and some of them are empty 1.49 2007-07-07 - Fix a CPAN signature issue 1.48 2007-03-11 - Fix a problem when left joins optimizer fails to calculate a boolean expression because of lower case aggregators. 1.47 2007-03-04 - Do the search in unions only when we must do them, not on every call to the Next method - Don't index ex/ dir to avoid complains by the indexer of PAUSE/CPAN 1.46 2007-02-25 - when doing a union, we need to actually search, rather than just doing a count - add support for testing with Oracle backend - Use CROSS JOIN instead of ',' as SQL parsers in Pg and some mysql are buggy and cannot parse "FROM X, Y JOIN Z ON Z.f = X.f" - deprecate DEBUG method, it's still there but produce warning - fix CleanSlate method that was missing several keys - fix a long standing bug we had, we didn't write depends_on data about a join, so we could build queries with incorrect parens around join conditions - fix default values for ALIAS1 argument in the Join method, istead of defaulting FIELD1 to 'main' value - fix a TODO test - internal refactoring of a storage for query's conditions, instead of building query strings right after the limit or join, we now build a perl structure - don't clone attributes that don't exists in the Clone method - we use Encode module without perl version check for a long time, so we can get rid of all checks for the version and load the module at compile time everywhere we need it - implement MayBeNull method in the handler that checks if applied conditions allow NULLs in the result set - implement cascaded LEFT JOINs optimization - additional tests for CleanSlate and Clone methods, ENTRY_AGGREGATOR argument, different types of joins and LEFT JOIN optimizer 1.45 2006-09-26 - Postgres: fix "$rec->Create();" - Postgres: fix "$rec->Create( IntegerColumn => '' );" - Postgres: fix "$rec->SetIntegerColumn( '' );" - Postgres: add test - cleanup ::Record::Cachable - use cache in: $a->LoadByCols(...); $b->LoadById( $a->id ); - add cache tests 1.44 2006-05-27 - DBIx::SearchBuilder::Handle::DatabaseVersion enhancements 1.43 2006-04-12 - Fix to the sequence compatibility fixes. For backwards compatibility. 1.42 2006-04-10 - Signatures fixed 1.41 2006-04-10 - PG 8.1 sequence compatibility fixes from Daniel Tabuenca 1.40 2006-03-10 - 'NOT STARTSWITH' and 'NOT ENDSWITH' 1.39 2006-02-16 - Allow ORs on left joins 1.38 2005-12-29 - Released 1.37 dev series 1.37_01 2005-12-08 - Switched Postgres sequence lookups to use CURRVAL, rather than OIDs 1.36 2005-12-02 - Change to how we resolve virtual columns to deal with a "no such attribute" bug in RT 1.35 2005-11-02 - Doc fixes and OrderBy cleanup from ruslan 1.34 2005-11-02 - Clone support from Ruslan 1.33 2005-09-22 - Better SQL statement logging from alex 1.32 2005-09-01 - DBD::SQLite is necessary for the test suite to run correctl 1.31 2005-07-29 - Updated MANIFEST to fix a build issue - Thanks to Andy Lester and David Glasser 1.30_03 2005-06-09 - 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. - 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 2005-05-22 - 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 2005-05-16 - Patches from Ruslan to switch to using 'capitalization.pm' for our regular_case subroutine aliases 1.30 2005-07-28 - Removed {{{ and }}} fold markers. Patch from Ruslan 1.27 2005-05-08 - Added supoprt for functions containing "?" to represent the parameter in ->Column() - Added better support for functional columns in search listings and group by clauses 1.26 2005-04-17 - Added support for expression based left joins 1.25 2005-04-09 - Backed out a change introduced in 1.23 that caused table and column names to be quoted, causing Postgres to flip out. 1.24 2005-04-06 - Added a new "SearchBuilder::Unique" module for uniquifying search results 1.23 - Now use DBI->quote_identifier to quote column and table names (Ruslan) - Test suite updates (Ruslan) 1.22 2005-01-24 - Require encode since we require encode. 1.21 2005-01-22 - Oracle LOB handling caused us to corrupt item values on update. - Just before inserting things into the database, turn off their utf8 flag. The flag didn't have any positve impact _and_ it can take down recent DBD::Oracle releases. (This is a new failure in DBD::Oracle 1.16) 1.20 2005-01-18 - Minor test suite fixes from Ruslan. 1.19 2005-01-08 - 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 - Release the changes from 1.17 1.17_03 - Properly mark BLOB columns in UPDATE calls. (DBD::Oracle 1.16 broke without this) 1.17_02 - Better handling of empty values for SB::Record::_Accessible. ( --Ruslan) 1.17_01 - More record tests from Ruz 1.16 2004-12-09 - 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 1.15 2004-11-27 - Fix a testsuite bug when DBD::SQLite isn't there 1.14 - Silenced warnings about uninitialized warnings when inserting null cols into the database. - Started adding lowercase method name aliases - Minor refactoring of 'id' method for a stupid, tiny perf improvement - Refactoring of DBIx::SearchBuilder::Record::Cachable for performance improvement - Added a FlushCache method to DBIx::SearchBuilder::Record::Cachable. - Started to flesh out a...test suite - 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 - Major documentation cleanups --Simon Cavalletto - A few tweaks to the ::Record class to eliminate the hard-coding of the name of the id column --Simon Cavalletto 1.12 - Better error handling for some query build failure cases - Corrected query builder for SQLite - More refactoring. 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. Special casing for the "id" method was removed. 1.10_05 - 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. 1.10_04 2004-08-30 - 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. 1.10_03 2004-08-30 - Cache Sanity fixes from Autrijus Tang 1.10_02 2004-08-26 1.10_01 2004-08-26 - Reimplemented DBIx::SearchBuilder:::Record::Cachable to use Cache::Simple::TimedExpiry. This should make it faster and more memory efficient. 1.10 - Identical to 1.10_05 1.02_03 2004-07-22 - Additional bullet proofing for joins. Now we default to ALIAS1 being "main" (cubic@acronis.ru) 1.02_02 2004-07-20 - Fixed a join bug that mostly manifests as a 'Dependency chain' error on RT2. 1.02_01 2004-07-07 - magic _Object instantiation from cubic@acronis.ru - make SB::_Handle settable directly (cubic@acronis.ru) - document the above 1.01 2004-06-27 - Releasing 1.00_06 as stable 1.00_06 - Pg/Oracle: Don't attempt to do case insensitive comparisons on integer values. 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 everyone gets the benefit. 1.00_03 - Remove "AS" from table name aliases on joins, since Oracle doesn't like em. 1.00_02 - Slightly cleaner code in SearchBuilder->GotoPage 1.00_01 - Better handling of case insensitive comparisons on Postgres - Proper support for query paging on SQLite 0.99 - Bundled changes from 0.98* and released production version - Removed duplicate code in cache expiry routines Experimental SearchBuilder::Union collection object. - Released at the YAPC::Taipei::22004 Release Party 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 0.98_02 - Better handling of != clauses on Postgres 0.97_02 - Support for "Group By" clauses. - Support for delayed load of certain columns from Autrijus Tang. 0.97_01 - Oracle doesn't support binary-safe clobs in a reasonable manner. 0.96_01 - Fix a couple of spurious warnings in Record::Cachable - Records loaded from multiple-record searches were never cached - correctly 0.96 - Releasing 0.96_01 as usable 0.95_03 - Allow case-insensitive loading by columns in SearchBuilder::Record - Record::LoadByCols now lets you specify operator and values 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 - 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 - Added support for multiple handles in one app from Autrijus Tang (#4167) - Added initial Informix database driver from Oliver Tappe 0.92 2003-09-04 - Fixed a bug that caused certain types of pre-canned table aliases to fail to work on join 0.90 2003-08-08 - Disable Class::ReturnValue's stack trace feature as it interacted poorly with a stack containing lots of data 0.89_02 2003-07-19 - Patch from Grant DeGraw to allow ordering by multiple columns. 0.89_01 2003-07-18 - Patch from Brook for: - better oracle support - remove "SELECT DISTINCT" when it's not necessary 0.88 2003-06-23 - More correct generation of "Distinct" keyword on counts for queries with left joins 0.87 2003-06-16 - Changed DBIx::SB::Record::Cachable to expire cached object when a "deeper" method call changes their values 0.86 2003-06-07 - Doing conditional connections was failing on postgres, because the handle was defined, but not connected 0.85 2003-06-07 - Stan's destroy fix was actually badly breaking RT - It's now an optional parameter. 0.84 2003-06-04 - Bumped the version for release 0.83_05 2003-06-02 - Provide support for blowing away nested transactions that aren't yet committed. 0.83_04 2003-06-02 - Fixed how values of returned hashes are downcased. - Should be a minor perf improvement 0.83_03 2003-05-30 - Moved Stan's destryo fix to the right file 0.83_02 2003-05-27 - Better oracle support for unique ids on indexes from Brook 0.83_01 2003-05-27 - Stan's DESTROY fix - Mathieu Arnold's patch to make function naming for autoloaded functions a bit more flexible 0.82 2003-05-19 - Query builder changes to improve some join performance - Fixes to a tight loop for cache expiry 0.81_04 2003-04-14 - Fixed a bug in "Distinct" logic introduced in 0.81_01 0.81_03 2003-04-13 - Patches for Oracle BLOB support from Brook Schofield 0.81_02 2003-04-13 - Rebuilt Postgres query generator. 0.81_01 2003-03-27 - Select Distinct altered to support oracle 0.80 2003-03-08 - Count method enhanced to ignore "LIMIT"s - LIMIT behaviour changed to be handle specific 0.79 2003-01-19 - ReadableAttributes and WritableAttributes added as methods to Record.pm 0.78 2003-01-16 - SB->Count should return no results unless the search is limited - Eliminate a warning on empty searches 0.77 2003-01-15 - No longer attempt to cache (and fail) objects that haven't been database-loaded 0.76 2002-12-30 - Extra checking for cache misses in DBIx::SearchBuilder::Record::Cachable - 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 2002-12-06 - Applying a patch from Rob Spier which enables 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 2002-10-11 - Adding support for mysqlPP 0.73 2002-09-10 - More class-returnvalue ification - Fixed a caching bug that caused multiple copies of an object in memory to not be kept in sync 0.72 2002-08-28 - Fixed bug in setting a column to the value of an SQL statement. 0.70 2002-08-27 - Better support for Postgres 7.2 and transactions. 0.62 2002-07-05 - Support for Class::ReturnValue to channel errors up when expected - Dependency on Class::ReturnValue - Minor cleanups and refactorings to allow percolation of errors on create 0.34 2001-05-23 - SearchBuilder.pm - refactored to allow LEFT joins. 0.31 2001-05-12 - SearchBuilder::Record::Cachable now constructs cache keys in a way that doesn't lose when records in different tables have the same keys. 0.30 2001-05-11 - Added DBIx::SearchBuilder::Record::Cachable from - 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 ;) 0.01 2000-08-29 - original version; created by h2xs 1.19 DBIx-SearchBuilder-1.71/MANIFEST000644 000765 000024 00000003071 14123427067 016750 0ustar00sunnavystaff000000 000000 .gitignore Changes ex/create_tables.pl ex/Example/Model/Address.pm ex/Example/Model/Employee.pm inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/DBIx/SearchBuilder.pm lib/DBIx/SearchBuilder/Handle.pm lib/DBIx/SearchBuilder/Handle/Informix.pm lib/DBIx/SearchBuilder/Handle/mysql.pm lib/DBIx/SearchBuilder/Handle/mysqlPP.pm lib/DBIx/SearchBuilder/Handle/ODBC.pm lib/DBIx/SearchBuilder/Handle/Oracle.pm lib/DBIx/SearchBuilder/Handle/Pg.pm lib/DBIx/SearchBuilder/Handle/SQLite.pm lib/DBIx/SearchBuilder/Handle/Sybase.pm lib/DBIx/SearchBuilder/Record.pm lib/DBIx/SearchBuilder/Record/Cachable.pm lib/DBIx/SearchBuilder/SchemaGenerator.pm lib/DBIx/SearchBuilder/Union.pm lib/DBIx/SearchBuilder/Unique.pm lib/DBIx/SearchBuilder/Util.pm Makefile.PL MANIFEST This list of files META.yml README ROADMAP SIGNATURE t/00.load.t t/01basics.t t/01nocap_api.t t/01records.t t/01searches.t t/02distinct_values.t t/02null_order.t t/02order_outer.t t/02records_cachable.t t/02records_datetime.t t/02records_dt_interval.t t/02records_integers.t t/02records_object.t t/02searches_function.t t/03searches_bind.t t/02searches_joins.t t/03compatibility.t t/03cud_from_select.t t/03rebless.t t/03transactions.t t/03versions.t t/04mysql_identifier_quoting.t t/10schema.t t/11schema_records.t t/20set_edge_cases.t t/pod.t t/testmodels.pl t/utils.pl DBIx-SearchBuilder-1.71/ex/000755 000765 000024 00000000000 14123431630 016221 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/t/000755 000765 000024 00000000000 14123431630 016050 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/README000644 000765 000024 00000002577 13275205765 016517 0ustar00sunnavystaff000000 000000 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. DBIx-SearchBuilder-1.71/.gitignore000644 000765 000024 00000000130 13275205765 017606 0ustar00sunnavystaff000000 000000 Makefile Makefile.bak Makefile.old MANIFEST.old MANIFEST.bak pm_to_blib blib/ MYMETA.* DBIx-SearchBuilder-1.71/META.yml000644 000765 000024 00000001473 14123431566 017073 0ustar00sunnavystaff000000 000000 --- abstract: 'Encapsulate SQL queries and rows in simple perl objects' author: - 'Best Practical Solutions, LLC ' build_requires: DBD::SQLite: 0 ExtUtils::MakeMaker: 6.36 File::Temp: 0 Test::More: 0.52 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.19' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: DBIx-SearchBuilder no_index: directory: - ex - inc - t requires: Cache::Simple::TimedExpiry: '0.21' Class::Accessor: 0 Class::ReturnValue: 0.4 Clone: 0 DBI: 0 DBIx::DBSchema: 0 Encode: '1.99' Scalar::Util: 0 Want: 0 capitalization: '0.03' resources: license: http://dev.perl.org/licenses/ version: '1.71' DBIx-SearchBuilder-1.71/lib/000755 000765 000024 00000000000 14123431630 016353 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/Makefile.PL000755 000765 000024 00000001272 13700705234 017570 0ustar00sunnavystaff000000 000000 BEGIN { push @INC, '.' } use inc::Module::Install; name ('DBIx-SearchBuilder'); all_from('lib/DBIx/SearchBuilder.pm'); requires('DBI'); requires('Want'); requires('Encode' => '1.99'); requires('Class::ReturnValue', 0.40); requires('Cache::Simple::TimedExpiry' => '0.21'); requires('Clone'); requires('Scalar::Util'); build_requires('Test::More' => 0.52); build_requires('DBD::SQLite'); build_requires('File::Temp'); features( 'Lower case API' => [ -default => 0, 'capitalization' => '0.03', ], 'Schema generation' => [ -default => 1, 'DBIx::DBSchema' => '', 'Class::Accessor' => '', ], ); auto_install(); no_index directory => 't'; no_index directory => 'ex'; sign; WriteAll(); DBIx-SearchBuilder-1.71/lib/DBIx/000755 000765 000024 00000000000 14123431630 017141 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/000755 000765 000024 00000000000 14123431630 021655 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder.pm000755 000765 000024 00000141110 14123431535 022220 0ustar00sunnavystaff000000 000000 package DBIx::SearchBuilder; use strict; use warnings; our $VERSION = "1.71"; use Clone qw(); use Encode qw(); use Scalar::Util qw(blessed); use DBIx::SearchBuilder::Util qw/ sorted_values /; our $PREFER_BIND = $ENV{SB_PREFER_BIND}; =head1 NAME 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 = My::Things->new( Handle => $handle ); $sb->Limit( FIELD => "column_1", VALUE => "matchstring" ); while ( my $record = $sb->Next ) { 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 and a subclass of C for each table that you wish to access. (See the documentation of C for more information on subclassing it.) Your C subclass must override C, 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 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 has the alias C. =head1 METHODS =cut =head2 new Creates a new SearchBuilder object and immediately calls C<_Init> with the same parameters that were passed to C. If you haven't overridden C<_Init> in your subclass, this means that you should pass in a C (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; my $class = ref($proto) || $proto; my $self = {}; bless( $self, $class ); $self->_Init(@_); return ($self); } =head2 _Init This method is called by C with whatever arguments were passed to C. By default, it takes a C object as a C argument, although this is not necessary if your subclass overrides C<_Handle>. =cut sub _Init { my $self = shift; my %args = ( Handle => undef, @_ ); $self->_Handle( $args{'Handle'} ); $self->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 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 sub CleanSlate { my $self = shift; $self->RedoSearch(); $self->{'itemscount'} = 0; $self->{'limit_clause'} = ""; $self->{'order'} = ""; $self->{'alias_count'} = 0; $self->{'first_row'} = 0; $self->{'must_redo_search'} = 1; $self->{'show_rows'} = 0; $self->{'joins_are_distinct'} = undef; @{ $self->{'aliases'} } = (); delete $self->{$_} for qw( items left_joins raw_rows count_all subclauses restrictions _open_parens _close_parens group_by columns query_hint _bind_values _prefer_bind ); #we have no limit statements. DoSearch won't work. $self->_isLimited(0); } =head2 Clone Returns copy of the current object with all search restrictions. =cut sub Clone { my $self = shift; my $obj = bless {}, ref($self); %$obj = %$self; delete $obj->{$_} for qw( items ); $obj->{'must_redo_search'} = 1; $obj->{'itemscount'} = 0; $obj->{ $_ } = Clone::clone( $obj->{ $_ } ) foreach grep exists $self->{ $_ }, $self->_ClonedAttributes; return $obj; } =head2 _ClonedAttributes Returns list of the object's fields that should be copied. If your subclass store references in the object that should be copied while clonning then you probably want override this method and add own values to the list. =cut sub _ClonedAttributes { return qw( aliases left_joins subclauses restrictions order_by group_by columns query_hint ); } =head2 _Handle [DBH] Get or set this object's DBIx::SearchBuilder::Handle object. =cut sub _Handle { my $self = shift; if (@_) { $self->{'DBIxHandle'} = shift; } return ( $self->{'DBIxHandle'} ); } =head2 _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). =cut sub _DoSearch { my $self = shift; my $QueryString = $self->BuildSelectQuery(); # If we're about to redo the search, we need an empty set of items and a reset iterator delete $self->{'items'}; $self->{'itemscount'} = 0; my $records = $self->_Handle->SimpleQuery( $QueryString, @{ $self->{_bind_values} || [] } ); return 0 unless $records; while ( my $row = $records->fetchrow_hashref() ) { my $item = $self->NewItem(); $item->LoadFromHash($row); $self->AddRecord($item); } return $self->_RecordCount if $records->err; $self->{'must_redo_search'} = 0; return $self->_RecordCount; } =head2 AddRecord RECORD Adds a record object to this collection. =cut sub AddRecord { my $self = shift; my $record = shift; 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 and C. =cut sub _DoCount { my $self = shift; my $all = shift || 0; my $QueryString = $self->BuildSelectCountQuery(); my $records = $self->_Handle->SimpleQuery( $QueryString, @{ $self->{_bind_values} || [] } ); return 0 unless $records; my @row = $records->fetchrow_array(); return 0 if $records->err; $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 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, say). =cut sub _ApplyLimits { my $self = shift; my $statementref = shift; $self->_Handle->ApplyLimits($statementref, $self->RowsPerPage, $self->FirstRow); $$statementref =~ s/main\.\*/join(', ', @{$self->{columns}})/eg if $self->{columns} and @{$self->{columns}}; } =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 { my $self = shift; my $statementref = shift; # XXX - Postgres gets unhappy with distinct and OrderBy aliases $self->_Handle->DistinctQuery($statementref, $self) } =head2 _BuildJoins Build up all of the joins we need to perform this query. =cut sub _BuildJoins { my $self = shift; return ( $self->_Handle->_BuildJoins($self) ); } =head2 _isJoined Returns true if this SearchBuilder will be joining multiple tables together. =cut sub _isJoined { my $self = shift; if ( keys %{ $self->{'left_joins'} } ) { return (1); } else { return (@{ $self->{'aliases'} }); } } # LIMIT clauses are used for restricting ourselves to subsets of the search. sub _LimitClause { my $self = shift; my $limit_clause; if ( $self->RowsPerPage ) { $limit_clause = " LIMIT "; if ( $self->FirstRow != 0 ) { $limit_clause .= $self->FirstRow . ", "; } $limit_clause .= $self->RowsPerPage; } else { $limit_clause = ""; } return $limit_clause; } =head2 _isLimited If we've limited down this search, return true. Otherwise, return false. =cut sub _isLimited { my $self = shift; if (@_) { $self->{'is_limited'} = shift; } else { return ( $self->{'is_limited'} ); } } =head2 BuildSelectQuery PreferBind => 1|0 Builds a query string for a "SELECT rows from Tables" statement for this SearchBuilder object If C is true, the generated query will use bind variables where possible. If C is not passed, it defaults to package variable C<$DBIx::SearchBuilder::PREFER_BIND>, which defaults to C<$ENV{SB_PREFER_BIND}>. To override global C<$DBIx::SearchBuilder::PREFER_BIND> for current object only, you can also set C<_prefer_bind> accordingly, e.g. $sb->{_prefer_bind} = 1; =cut sub BuildSelectQuery { my $self = shift; # The initial SELECT or SELECT DISTINCT is decided later my $QueryString = $self->_BuildJoins . " "; $QueryString .= $self->_WhereClause . " " if ( $self->_isLimited > 0 ); $self->_OptimizeQuery(\$QueryString, @_); my $QueryHint = $self->QueryHintFormatted; # DISTINCT query only required for multi-table selects # when we have group by clause then the result set is distinct as # it must contain only columns we group by or results of aggregate # functions which give one result per group, so we can skip DISTINCTing if ( my $clause = $self->_GroupClause ) { $QueryString = "SELECT" . $QueryHint . "main.* FROM $QueryString"; $QueryString .= $clause; $QueryString .= $self->_OrderClause; } elsif ( !$self->{'joins_are_distinct'} && $self->_isJoined ) { $self->_DistinctQuery(\$QueryString); } else { $QueryString = "SELECT" . $QueryHint . "main.* FROM $QueryString"; $QueryString .= $self->_OrderClause; } $self->_ApplyLimits(\$QueryString); return($QueryString) } =head2 BuildSelectCountQuery PreferBind => 1|0 Builds a SELECT statement to find the number of rows this SearchBuilder object would find. =cut sub BuildSelectCountQuery { my $self = shift; #TODO refactor DoSearch and DoCount such that we only have # one place where we build most of the querystring my $QueryString = $self->_BuildJoins . " "; $QueryString .= $self->_WhereClause . " " if ( $self->_isLimited > 0 ); $self->_OptimizeQuery(\$QueryString, @_); # DISTINCT query only required for multi-table selects if ($self->_isJoined) { $QueryString = $self->_Handle->DistinctCount(\$QueryString, $self); } else { my $QueryHint = $self->QueryHintFormatted; $QueryString = "SELECT" . $QueryHint . "count(main.id) FROM " . $QueryString; } return ($QueryString); } =head2 Next Returns the next row from the set as an object of the type defined by sub NewItem. When the complete set has been iterated through, returns undef and resets the search such that the following call to Next will start over with the first item retrieved from the database. =cut sub Next { my $self = shift; my @row; return (undef) unless ( $self->_isLimited ); $self->_DoSearch() if $self->{'must_redo_search'}; if ( $self->{'itemscount'} < $self->_RecordCount ) { #return the next item my $item = ( $self->{'items'}[ $self->{'itemscount'} ] ); $self->{'itemscount'}++; return ($item); } else { #we've gone through the whole list. reset the count. $self->GotoFirstItem(); return (undef); } } =head2 GotoFirstItem Starts the recordset counter over from the first item. The next time you call Next, you'll get the first item returned by the database, as if you'd just started iterating through the result set. =cut sub GotoFirstItem { my $self = shift; $self->GotoItem(0); } =head2 GotoItem Takes an integer N and sets the record iterator to N. The first time L is called afterwards, it will return the Nth item found by the search. You should only call GotoItem after you've already fetched at least one result or otherwise forced the search query to run (such as via L). If GotoItem is called before the search query is ever run, it will reset the item iterator and L will return the L item. =cut sub GotoItem { my $self = shift; my $item = shift; $self->{'itemscount'} = $item; } =head2 First Returns the first item =cut sub First { my $self = shift; $self->GotoFirstItem(); return ( $self->Next ); } =head2 Last Returns the last item =cut sub Last { my $self = shift; $self->_DoSearch if $self->{'must_redo_search'}; $self->GotoItem( ( $self->Count ) - 1 ); return ( $self->Next ); } =head2 DistinctFieldValues Returns list with distinct values of field. Limits on collection are accounted, so collection should be Led to get values from the whole table. Takes paramhash with the following keys: =over 4 =item Field Field name. Can be first argument without key. =item Order 'ASC', 'DESC' or undef. Defines whether results should be sorted or not. By default results are not sorted. =item Max Maximum number of elements to fetch. =back =cut sub DistinctFieldValues { my $self = shift; my %args = ( Field => undef, Order => undef, Max => undef, @_%2 ? (Field => @_) : (@_) ); my $query_string = $self->_BuildJoins; $query_string .= ' '. $self->_WhereClause if $self->_isLimited > 0; my $query_hint = $self->QueryHintFormatted; my $column = 'main.'. $args{'Field'}; $query_string = "SELECT" . $query_hint . "DISTINCT $column FROM $query_string"; if ( $args{'Order'} ) { $query_string .= ' ORDER BY '. $column .' '. ($args{'Order'} =~ /^des/i ? 'DESC' : 'ASC'); } my $dbh = $self->_Handle->dbh; my $list = $dbh->selectcol_arrayref( $query_string, { MaxRows => $args{'Max'} } ); return $list? @$list : (); } =head2 ItemsArrayRef Return a refernece to an array containing all objects found by this search. =cut sub ItemsArrayRef { my $self = shift; #If we're not limited, return an empty array return [] unless $self->_isLimited; #Do a search if we need to. $self->_DoSearch() if $self->{'must_redo_search'}; #If we've got any items in the array, return them. # Otherwise, return an empty array return ( $self->{'items'} || [] ); } =head2 NewItem NewItem must be subclassed. It is used by DBIx::SearchBuilder to create record objects for each row returned from the database. =cut sub NewItem { my $self = shift; die "DBIx::SearchBuilder needs to be subclassed. you can't use it directly.\n"; } =head2 RedoSearch Takes no arguments. Tells DBIx::SearchBuilder that the next time it's asked for a record, it should requery the database =cut sub RedoSearch { my $self = shift; $self->{'must_redo_search'} = 1; } =head2 UnLimit UnLimit clears all restrictions and causes this object to return all rows in the primary table. =cut sub UnLimit { my $self = shift; $self->_isLimited(-1); } =head2 Limit Limit takes a hash of parameters with the following keys: =over 4 =item TABLE Can be set to something different than this table if a join is wanted (that means we can't do recursive joins as for now). =item ALIAS Unless ALIAS is set, the join criterias will be taken from EXT_LINKFIELD and INT_LINKFIELD and added to the criterias. If ALIAS is set, new criterias about the foreign table will be added. =item LEFTJOIN To apply the Limit inside the ON clause of a previously created left join, pass this option along with the alias returned from creating the left join. ( This is similar to using the EXPRESSION option when creating a left join but this allows you to refer to the join alias in the expression. ) =item FIELD Column to be checked against. =item FUNCTION Function that should be checked against or applied to the FIELD before check. See L for rules. =item VALUE Should always be set and will always be quoted. =item OPERATOR OPERATOR is the SQL operator to use for this phrase. Possible choices include: =over 4 =item "=" =item "!=" =item "LIKE" In the case of LIKE, the string is surrounded in % signs. Yes. this is a bug. =item "NOT LIKE" =item "STARTSWITH" STARTSWITH is like LIKE, except it only appends a % at the end of the string =item "ENDSWITH" 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. =item "IN" and "NOT IN" VALUE can be an array reference or an object inherited from this class. If it's not then it's treated as any other operator and in most cases SQL would be wrong. Values in array are considered as constants and quoted according to QUOTEVALUE. If object is passed as VALUE then its select statement is used. If no L is selected then C is used, if more than one selected then warning is issued and first column is used. =back =item ENTRYAGGREGATOR Can be C or C (or anything else valid to aggregate two clauses in SQL). Special value is C which means that no entry aggregator should be used. The default value is C. =item CASESENSITIVE on some databases, such as postgres, setting CASESENSITIVE to 1 will make this search case sensitive =item SUBCLAUSE Subclause allows you to assign tags to Limit statements. Statements with matching SUBCLAUSE tags will be grouped together in the final SQL statement. Example: Suppose you want to create Limit statements which would produce results the same as the following SQL: SELECT * FROM Users WHERE EmailAddress OR Name OR RealName OR Email LIKE $query; You would use the following Limit statements: $folks->Limit( FIELD => 'EmailAddress', OPERATOR => 'LIKE', VALUE => "$query", SUBCLAUSE => 'groupsearch'); $folks->Limit( FIELD => 'Name', OPERATOR => 'LIKE', VALUE => "$query", SUBCLAUSE => 'groupsearch'); $folks->Limit( FIELD => 'RealName', OPERATOR => 'LIKE', VALUE => "$query", SUBCLAUSE => 'groupsearch'); =back =cut sub Limit { my $self = shift; my %args = ( TABLE => $self->Table, ALIAS => undef, FIELD => undef, FUNCTION => undef, VALUE => undef, QUOTEVALUE => 1, ENTRYAGGREGATOR => undef, CASESENSITIVE => undef, OPERATOR => '=', SUBCLAUSE => undef, LEFTJOIN => undef, @_ # get the real argumentlist ); unless ( $args{'ENTRYAGGREGATOR'} ) { if ( $args{'LEFTJOIN'} ) { $args{'ENTRYAGGREGATOR'} = 'AND'; } else { $args{'ENTRYAGGREGATOR'} = 'OR'; } } #since we're changing the search criteria, we need to redo the search $self->RedoSearch(); if ( $args{'OPERATOR'} ) { #If it's a like, we supply the %s around the search term if ( $args{'OPERATOR'} =~ /LIKE/i ) { $args{'VALUE'} = "%" . $args{'VALUE'} . "%"; } elsif ( $args{'OPERATOR'} =~ /STARTSWITH/i ) { $args{'VALUE'} = $args{'VALUE'} . "%"; } elsif ( $args{'OPERATOR'} =~ /ENDSWITH/i ) { $args{'VALUE'} = "%" . $args{'VALUE'}; } elsif ( $args{'OPERATOR'} =~ /\bIN$/i ) { if ( blessed $args{'VALUE'} && $args{'VALUE'}->isa(__PACKAGE__) ) { # if no columns selected then select id local $args{'VALUE'}{'columns'} = $args{'VALUE'}{'columns'}; unless ( $args{'VALUE'}{'columns'} ) { $args{'VALUE'}->Column( FIELD => 'id' ); } elsif ( @{ $args{'VALUE'}{'columns'} } > 1 ) { warn "Collection in '$args{OPERATOR}' with more than one column selected, using first"; splice @{ $args{'VALUE'}{'columns'} }, 1; } $args{'VALUE'} = '('. $args{'VALUE'}->BuildSelectQuery(PreferBind => 0) .')'; $args{'QUOTEVALUE'} = 0; } elsif ( ref $args{'VALUE'} ) { if ( $args{'QUOTEVALUE'} ) { my $dbh = $self->_Handle->dbh; $args{'VALUE'} = join ', ', map $dbh->quote( $_ ), @{ $args{'VALUE'} }; } else { $args{'VALUE'} = join ', ', @{ $args{'VALUE'} }; } $args{'VALUE'} = "($args{VALUE})"; $args{'QUOTEVALUE'} = 0; } else { # otherwise behave in backwards compatible way } } $args{'OPERATOR'} =~ s/(?:MATCHES|ENDSWITH|STARTSWITH)/LIKE/i; if ( $args{'OPERATOR'} =~ /IS/i ) { $args{'VALUE'} = 'NULL'; $args{'QUOTEVALUE'} = 0; } } if ( $args{'QUOTEVALUE'} ) { #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. $args{'VALUE'} = $self->_Handle->dbh->quote( $args{'VALUE'} ); } my $Alias = $self->_GenericRestriction(%args); warn "No table alias set!" unless $Alias; # We're now limited. people can do searches. $self->_isLimited(1); if ( defined($Alias) ) { return ($Alias); } else { return (1); } } sub _GenericRestriction { my $self = shift; my %args = ( TABLE => $self->Table, FIELD => undef, FUNCTION => undef, VALUE => undef, ALIAS => undef, LEFTJOIN => undef, ENTRYAGGREGATOR => undef, OPERATOR => '=', SUBCLAUSE => undef, CASESENSITIVE => undef, QUOTEVALUE => undef, @_ ); #TODO: $args{'VALUE'} should take an array of values and generate # the proper where clause. #If we're performing a left join, we really want the alias to be the #left join criterion. if ( defined $args{'LEFTJOIN'} && !defined $args{'ALIAS'} ) { $args{'ALIAS'} = $args{'LEFTJOIN'}; } # if there's no alias set, we need to set it unless ( $args{'ALIAS'} ) { #if the table we're looking at is the same as the main 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, # I'll change it. $args{'ALIAS'} = 'main'; } # if we're joining, we need to work out the table alias else { $args{'ALIAS'} = $self->NewAlias( $args{'TABLE'} ); } } # Set this to the name of the field and the alias, unless we've been # handed a subclause name my $ClauseId = $args{'SUBCLAUSE'} || ($args{'ALIAS'} . "." . $args{'FIELD'}); # If we're trying to get a leftjoin restriction, let's set # $restriction to point there. Otherwise, let's construct normally. my $restriction; if ( $args{'LEFTJOIN'} ) { if ( $args{'ENTRYAGGREGATOR'} ) { $self->{'left_joins'}{ $args{'LEFTJOIN'} }{'entry_aggregator'} = $args{'ENTRYAGGREGATOR'}; } $restriction = $self->{'left_joins'}{ $args{'LEFTJOIN'} }{'criteria'}{ $ClauseId } ||= []; } else { $restriction = $self->{'restrictions'}{ $ClauseId } ||= []; } my $QualifiedField = $self->CombineFunctionWithField( %args ); # If it's a new value or we're overwriting this sort of restriction, if ( $self->_Handle->CaseSensitive && defined $args{'VALUE'} && $args{'VALUE'} ne '' && $args{'VALUE'} ne "''" && ($args{'OPERATOR'} !~/IS/ && $args{'VALUE'} !~ /^null$/i)) { unless ( $args{'CASESENSITIVE'} || !$args{'QUOTEVALUE'} ) { ( $QualifiedField, $args{'OPERATOR'}, $args{'VALUE'} ) = $self->_Handle->_MakeClauseCaseInsensitive( $QualifiedField, $args{'OPERATOR'}, $args{'VALUE'} ); } } my $clause = { field => $QualifiedField, op => $args{'OPERATOR'}, value => $args{'VALUE'}, }; # Juju because this should come _AFTER_ the EA my @prefix; if ( $self->{_open_parens}{ $ClauseId } ) { @prefix = ('(') x delete $self->{_open_parens}{ $ClauseId }; } if ( lc( $args{'ENTRYAGGREGATOR'} || "" ) eq 'none' || !@$restriction ) { @$restriction = (@prefix, $clause); } else { push @$restriction, $args{'ENTRYAGGREGATOR'}, @prefix, $clause; } return ( $args{'ALIAS'} ); } sub _OpenParen { my ($self, $clause) = @_; $self->{_open_parens}{ $clause }++; } # Immediate Action sub _CloseParen { my ( $self, $clause ) = @_; my $restriction = ($self->{'restrictions'}{ $clause } ||= []); push @$restriction, ')'; } sub _AddSubClause { my $self = shift; my $clauseid = shift; my $subclause = shift; $self->{'subclauses'}{ $clauseid } = $subclause; } sub _WhereClause { my $self = shift; #Go through all the generic restrictions and build up the "generic_restrictions" subclause # That's the only one that SearchBuilder builds itself. # Arguably, the abstraction should be better, but I don't really see where to put it. $self->_CompileGenericRestrictions(); #Go through all restriction types. Build the where clause from the #Various subclauses. my $where_clause = ''; foreach my $subclause ( grep $_, sorted_values($self->{'subclauses'}) ) { $where_clause .= " AND " if $where_clause; $where_clause .= $subclause; } $where_clause = " WHERE " . $where_clause if $where_clause; return ($where_clause); } #Compile the restrictions to a WHERE Clause sub _CompileGenericRestrictions { my $self = shift; my $result = ''; #Go through all the restrictions of this type. Buld up the generic subclause foreach my $restriction ( grep @$_, sorted_values($self->{'restrictions'}) ) { $result .= " AND " if $result; $result .= '('; foreach my $entry ( @$restriction ) { unless ( ref $entry ) { $result .= ' '. $entry . ' '; } else { $result .= join ' ', @{$entry}{qw(field op value)}; } } $result .= ')'; } return ($self->{'subclauses'}{'generic_restrictions'} = $result); } =head2 OrderBy PARAMHASH Orders the returned results by ALIAS.FIELD ORDER. Takes a paramhash of ALIAS, FIELD and ORDER. ALIAS defaults to C
. FIELD has no default value. ORDER defaults to ASC(ending). DESC(ending) is also a valid value for OrderBy. FIELD also accepts C format. =cut sub OrderBy { my $self = shift; $self->OrderByCols( { @_ } ); } =head2 OrderByCols ARRAY OrderByCols takes an array of paramhashes of the form passed to OrderBy. The result set is ordered by the items in the array. =cut sub OrderByCols { my $self = shift; my @args = @_; $self->{'order_by'} = \@args; $self->RedoSearch(); } =head2 _OrderClause returns the ORDER BY clause for the search. =cut sub _OrderClause { my $self = shift; return '' unless $self->{'order_by'}; my $nulls_order = $self->_Handle->NullsOrder; my $clause = ''; foreach my $row ( @{$self->{'order_by'}} ) { my %rowhash = ( ALIAS => 'main', FIELD => undef, ORDER => 'ASC', %$row ); if ($rowhash{'ORDER'} && $rowhash{'ORDER'} =~ /^des/i) { $rowhash{'ORDER'} = "DESC"; $rowhash{'ORDER'} .= ' '. $nulls_order->{'DESC'} if $nulls_order; } else { $rowhash{'ORDER'} = "ASC"; $rowhash{'ORDER'} .= ' '. $nulls_order->{'ASC'} if $nulls_order; } $rowhash{'ALIAS'} = 'main' unless defined $rowhash{'ALIAS'}; if ( defined $rowhash{'ALIAS'} and $rowhash{'FIELD'} and $rowhash{'ORDER'} ) { if ( length $rowhash{'ALIAS'} && $rowhash{'FIELD'} =~ /^(\w+\()(.*\))$/ ) { # handle 'FUNCTION(FIELD)' formatted fields $rowhash{'ALIAS'} = $1 . $rowhash{'ALIAS'}; $rowhash{'FIELD'} = $2; } $clause .= ($clause ? ", " : " "); $clause .= $rowhash{'ALIAS'} . "." if length $rowhash{'ALIAS'}; $clause .= $rowhash{'FIELD'} . " "; $clause .= $rowhash{'ORDER'}; } } $clause = " ORDER BY$clause " if $clause; return $clause; } =head2 GroupByCols ARRAY_OF_HASHES Each hash contains the keys FIELD, FUNCTION and ALIAS. Hash combined into SQL with L. =cut sub GroupByCols { my $self = shift; my @args = @_; $self->{'group_by'} = \@args; $self->RedoSearch(); } =head2 _GroupClause Private function to return the "GROUP BY" clause for this query. =cut sub _GroupClause { my $self = shift; return '' unless $self->{'group_by'}; my $clause = ''; foreach my $row ( @{$self->{'group_by'}} ) { my $part = $self->CombineFunctionWithField( %$row ) or next; $clause .= ', ' if $clause; $clause .= $part; } return '' unless $clause; return " GROUP BY $clause "; } =head2 NewAlias Takes the name of a table and paramhash with TYPE and DISTINCT. Use TYPE equal to C to indicate that it's LEFT JOIN. Old style way to call (see below) is also supported, but should be B: $records->NewAlias('aTable', 'left'); True DISTINCT value indicates that this join keeps result set distinct and DB side distinct is not required. See also L. Returns the string of a new Alias for that table, which can be used to Join tables or to Limit what gets found by a search. =cut sub NewAlias { my $self = shift; my $table = shift || die "Missing parameter"; my %args = @_%2? (TYPE => @_) : (@_); my $type = $args{'TYPE'}; my $alias = $self->_GetAlias($table); $table = $self->_Handle->QuoteName($table) if $self->_Handle->QuoteTableNames; unless ( $type ) { push @{ $self->{'aliases'} }, "$table $alias"; } elsif ( lc $type eq 'left' ) { my $meta = $self->{'left_joins'}{"$alias"} ||= {}; $meta->{'alias_string'} = " LEFT JOIN $table $alias "; $meta->{'type'} = 'LEFT'; $meta->{'depends_on'} = ''; } else { die "Unsupported alias(join) type"; } if ( $args{'DISTINCT'} && !defined $self->{'joins_are_distinct'} ) { $self->{'joins_are_distinct'} = 1; } elsif ( !$args{'DISTINCT'} ) { $self->{'joins_are_distinct'} = 0; } return $alias; } # _GetAlias is a private function which takes an tablename and # returns a new alias for that table without adding something # to self->{'aliases'}. This function is used by NewAlias # and the as-yet-unnamed left join code sub _GetAlias { my $self = shift; my $table = shift; $self->{'alias_count'}++; my $alias = $table . "_" . $self->{'alias_count'}; return ($alias); } =head2 Join Join instructs DBIx::SearchBuilder to join two tables. The standard form takes a param hash with keys ALIAS1, FIELD1, ALIAS2 and FIELD2. ALIAS1 and ALIAS2 are column aliases obtained from $self->NewAlias or a $self->Limit. FIELD1 and FIELD2 are the fields in ALIAS1 and ALIAS2 that should be linked, respectively. For this type of join, this method has no return value. Supplying the parameter TYPE => 'left' causes Join to preform a left join. in this case, it takes ALIAS1, FIELD1, TABLE2 and FIELD2. Because of the way that left joins work, this method needs a TABLE for the second field rather than merely an alias. For this type of join, it will return the alias generated by the join. Instead of ALIAS1/FIELD1, it's possible to specify EXPRESSION, to join ALIAS2/TABLE2 on an arbitrary expression. It is also possible to join to a pre-existing, already-limited L object, by passing it as COLLECTION2, instead of providing an ALIAS2 or TABLE2. By passing true value as DISTINCT argument join can be marked distinct. If all joins are distinct then whole query is distinct and SearchBuilder can avoid L call that can hurt performance of the query. See also L. =cut sub Join { my $self = shift; my %args = ( TYPE => 'normal', FIELD1 => undef, ALIAS1 => 'main', TABLE2 => undef, COLLECTION2 => undef, FIELD2 => undef, ALIAS2 => undef, @_ ); $self->_Handle->Join( SearchBuilder => $self, %args ); } =head2 Pages: size and changing Use L to set size of pages. L, L, L or L to change pages. L to do tricky stuff. =head3 RowsPerPage Get or set the number of rows returned by the database. Takes an optional integer which restricts the # of rows returned in a result. Zero or undef argument flush back to "return all records matching current conditions". Returns the current page size. =cut sub RowsPerPage { my $self = shift; if ( @_ && ($_[0]||0) != $self->{'show_rows'} ) { $self->{'show_rows'} = shift || 0; $self->RedoSearch; } return ( $self->{'show_rows'} ); } =head3 NextPage Turns one page forward. =cut sub NextPage { my $self = shift; $self->FirstRow( $self->FirstRow + 1 + $self->RowsPerPage ); } =head3 PrevPage Turns one page backwards. =cut sub PrevPage { my $self = shift; if ( ( $self->FirstRow - $self->RowsPerPage ) > 0 ) { $self->FirstRow( 1 + $self->FirstRow - $self->RowsPerPage ); } else { $self->FirstRow(1); } } =head3 FirstPage Jumps to the first page. =cut sub FirstPage { my $self = shift; $self->FirstRow(1); } =head3 GotoPage Takes an integer number and jumps to that page or first page if number omitted. Numbering starts from zero. =cut sub GotoPage { my $self = shift; my $page = shift || 0; $self->FirstRow( 1 + $self->RowsPerPage * $page ); } =head3 FirstRow Get or set the first row of the result set the database should return. Takes an optional single integer argrument. Returns the currently set integer minus one (this is historical issue). Usually you don't need this method. Use L, L and other methods to walk pages. It only may be helpful to get 10 records starting from 5th. =cut sub FirstRow { my $self = shift; if (@_ && ($_[0]||1) != ($self->{'first_row'}+1) ) { $self->{'first_row'} = shift; #SQL starts counting at 0 $self->{'first_row'}--; #gotta redo the search if changing pages $self->RedoSearch(); } return ( $self->{'first_row'} ); } =head2 _ItemsCounter Returns the current position in the record set. =cut sub _ItemsCounter { my $self = shift; return $self->{'itemscount'}; } =head2 Count Returns the number of records in the set. =cut sub Count { my $self = shift; # An unlimited search returns no tickets return 0 unless ($self->_isLimited); # If we haven't actually got all objects loaded in memory, we # really just want to do a quick count from the database. if ( $self->{'must_redo_search'} ) { # If we haven't already asked the database for the row count, do that $self->_DoCount unless ( $self->{'raw_rows'} ); #Report back the raw # of rows in the database return ( $self->{'raw_rows'} ); } # If we have loaded everything from the DB we have an # accurate count already. else { return $self->_RecordCount; } } =head2 CountAll Returns the total number of potential records in the set, ignoring any L settings. =cut # 22:24 [Robrt(500@outer.space)] It has to do with Caching. # 22:25 [Robrt(500@outer.space)] The documentation says it ignores the limit. # 22:25 [Robrt(500@outer.space)] But I don't believe thats true. # 22:26 [msg(Robrt)] yeah. I # 22:26 [msg(Robrt)] yeah. I'm not convinced it does anything useful right now # 22:26 [msg(Robrt)] especially since until a week ago, it was setting one variable and returning another # 22:27 [Robrt(500@outer.space)] I remember. # 22:27 [Robrt(500@outer.space)] It had to do with which Cached value was returned. # 22:27 [msg(Robrt)] (given that every time we try to explain it, we get it Wrong) # 22:27 [Robrt(500@outer.space)] Because Count can return a different number than actual NumberOfResults # 22:28 [msg(Robrt)] in what case? # 22:28 [Robrt(500@outer.space)] CountAll _always_ used the return value of _DoCount(), as opposed to Count which would return the cached number of # results returned. # 22:28 [Robrt(500@outer.space)] IIRC, if you do a search with a Limit, then raw_rows will == Limit. # 22:31 [msg(Robrt)] ah. # 22:31 [msg(Robrt)] that actually makes sense # 22:31 [Robrt(500@outer.space)] You should paste this conversation into the CountAll docs. # 22:31 [msg(Robrt)] perhaps I'll create a new method that _actually_ do that. # 22:32 [msg(Robrt)] since I'm not convinced it's been doing that correctly sub CountAll { my $self = shift; # An unlimited search returns no tickets return 0 unless ($self->_isLimited); # If we haven't actually got all objects loaded in memory, we # really just want to do a quick count from the database. # or if we have paging enabled then we count as well and store it in count_all if ( $self->{'must_redo_search'} || ( $self->RowsPerPage && !$self->{'count_all'} ) ) { # If we haven't already asked the database for the row count, do that $self->_DoCount(1); #Report back the raw # of rows in the database return ( $self->{'count_all'} ); } # if we have paging enabled and have count_all then return it elsif ( $self->RowsPerPage ) { return ( $self->{'count_all'} ); } # If we have loaded everything from the DB we have an # accurate count already. else { return $self->_RecordCount; } } =head2 IsLast Returns true if the current row is the last record in the set. =cut sub IsLast { my $self = shift; return undef unless $self->Count; if ( $self->_ItemsCounter == $self->Count ) { return (1); } else { return (0); } } =head2 Column Call to specify which columns should be loaded from the table. Each calls adds one column to the set. Takes a hash with the following named arguments: =over 4 =item FIELD Column name to fetch or apply function to. =item ALIAS Alias of a table the field is in; defaults to C
=item FUNCTION A SQL function that should be selected instead of FIELD or applied to it. =item AS The B alias to use instead of the default. The default column alias is either the column's name (i.e. what is passed to FIELD) if it is in this table (ALIAS is 'main') or an autogenerated alias. Pass C to skip column aliasing entirely. =back C, C and C are combined according to L. If a FIELD is provided and it is in this table (ALIAS is 'main'), then the column named FIELD and can be accessed as usual by accessors: $articles->Column(FIELD => 'id'); $articles->Column(FIELD => 'Subject', FUNCTION => 'SUBSTR(?, 1, 20)'); my $article = $articles->First; my $aid = $article->id; my $subject_prefix = $article->Subject; Returns the alias used for the column. If FIELD was not provided, or was from another table, then the returned column alias should be passed to the L method to retrieve the column's result: my $time_alias = $articles->Column(FUNCTION => 'NOW()'); my $article = $articles->First; my $now = $article->_Value( $time_alias ); To choose the column's alias yourself, pass a value for the AS parameter (see above). Be careful not to conflict with existing column aliases. =cut sub Column { my $self = shift; my %args = ( TABLE => undef, ALIAS => undef, FIELD => undef, FUNCTION => undef, @_); $args{'ALIAS'} ||= 'main'; my $name = $self->CombineFunctionWithField( %args ) || 'NULL'; my $column = $args{'AS'}; if (not defined $column and not exists $args{'AS'}) { if ( $args{FIELD} && $args{ALIAS} eq 'main' && (!$args{'TABLE'} || $args{'TABLE'} eq $self->Table ) ) { $column = $args{FIELD}; # make sure we don't fetch columns with duplicate aliases if ( $self->{columns} ) { my $suffix = " AS \L$column"; if ( grep index($_, $suffix, -length $suffix) >= 0, @{ $self->{columns} } ) { $column .= scalar @{ $self->{columns} }; } } } else { $column = "col" . @{ $self->{columns} ||= [] }; } } push @{ $self->{columns} ||= [] }, defined($column) ? "$name AS \L$column" : $name; return $column; } =head2 CombineFunctionWithField Takes a hash with three optional arguments: FUNCTION, FIELD and ALIAS. Returns SQL with all three arguments combined according to the following rules. =over 4 =item * FUNCTION or undef returned when FIELD is not provided =item * 'main' ALIAS is used if not provided =item * ALIAS.FIELD returned when FUNCTION is not provided =item * NULL returned if FUNCTION is 'NULL' =item * If FUNCTION contains '?' (question marks) then they are replaced with ALIAS.FIELD and result returned. =item * If FUNCTION has no '(' (opening parenthesis) then ALIAS.FIELD is appended in parentheses and returned. =back Examples: $obj->CombineFunctionWithField() => undef $obj->CombineFunctionWithField(FUNCTION => 'FOO') => 'FOO' $obj->CombineFunctionWithField(FIELD => 'foo') => 'main.foo' $obj->CombineFunctionWithField(ALIAS => 'bar', FIELD => 'foo') => 'bar.foo' $obj->CombineFunctionWithField(FUNCTION => 'FOO(?, ?)', FIELD => 'bar') => 'FOO(main.bar, main.bar)' $obj->CombineFunctionWithField(FUNCTION => 'FOO', ALIAS => 'bar', FIELD => 'baz') => 'FOO(bar.baz)' $obj->CombineFunctionWithField(FUNCTION => 'NULL', FIELD => 'bar') => 'NULL' =cut sub CombineFunctionWithField { my $self = shift; my %args = ( FUNCTION => undef, ALIAS => undef, FIELD => undef, @_ ); unless ( $args{'FIELD'} ) { return $args{'FUNCTION'} || undef; } my $field = ($args{'ALIAS'} || 'main') .'.'. $args{'FIELD'}; return $field unless $args{'FUNCTION'}; my $func = $args{'FUNCTION'}; if ( $func =~ /^DISTINCT\s*COUNT$/i ) { $func = "COUNT(DISTINCT $field)"; } # If we want to substitute elsif ( $func =~ s/\?/$field/g ) { # no need to do anything, we already replaced } # If we want to call a simple function on the column elsif ( $func !~ /\(/ && lc($func) ne 'null' ) { $func = "\U$func\E($field)"; } return $func; } =head2 Columns LIST Specify that we want to load only the columns in LIST =cut sub Columns { my $self = shift; $self->Column( FIELD => $_ ) for @_; } =head2 AdditionalColumn Calls L, but first ensures that this table's standard columns are selected as well. Thus, each call to this method results in an additional column selected instead of replacing the default columns. Takes a hash of parameters which is the same as L. Returns the result of calling L. =cut sub AdditionalColumn { my $self = shift; $self->Column( FUNCTION => "main.*", AS => undef ) unless grep { /^\Qmain.*\E$/ } @{$self->{columns}}; return $self->Column(@_); } =head2 Fields TABLE Return a list of fields in TABLE. These fields are in the case presented by the database, which may be case-sensitive. =cut sub Fields { return (shift)->_Handle->Fields( @_ ); } =head2 HasField { TABLE => undef, FIELD => undef } Returns true if TABLE has field FIELD. Return false otherwise Note: Both TABLE and FIELD are case-sensitive (See: L) =cut sub HasField { my $self = shift; my %args = ( FIELD => undef, TABLE => undef, @_); my $table = $args{TABLE} or die; my $field = $args{FIELD} or die; return grep { $_ eq $field } $self->Fields($table); } =head2 Table [TABLE] If called with an argument, sets this collection's table. Always returns this collection's table. =cut sub Table { my $self = shift; $self->{table} = shift if (@_); return $self->{table}; } =head2 QueryHint [Hint] If called with an argument, sets a query hint for this collection. Always returns the query hint. When the query hint is included in the SQL query, the C will be included for you. Here's an example query hint for Oracle: $sb->QueryHint("+CURSOR_SHARING_EXACT"); =cut sub QueryHint { my $self = shift; $self->{query_hint} = shift if (@_); return $self->{query_hint}; } =head2 QueryHintFormatted Returns the query hint formatted appropriately for inclusion in SQL queries. =cut sub QueryHintFormatted { my $self = shift; my $QueryHint = $self->QueryHint; return $QueryHint ? " /* $QueryHint */ " : " "; } sub _OptimizeQuery { my $self = shift; my $query = shift; my %args = ( PreferBind => $self->{_prefer_bind} // $PREFER_BIND, @_ ); undef $self->{_bind_values}; if ( $args{PreferBind} ) { ( $$query, my @bind_values ) = $self->_Handle->_ExtractBindValues($$query); if (@bind_values) { $self->{_bind_values} = \@bind_values; } } } =head1 DEPRECATED METHODS =head2 GroupBy DEPRECATED. Alias for the L method. =cut sub GroupBy { (shift)->GroupByCols( @_ ) } =head2 SetTable DEPRECATED. Alias for the L method. =cut sub SetTable { my $self = shift; return $self->Table(@_); } =head2 ShowRestrictions DEPRECATED AND DOES NOTHING. =cut sub ShowRestrictions { } =head2 ImportRestrictions DEPRECATED AND DOES NOTHING. =cut sub ImportRestrictions { } # not even documented sub DEBUG { warn "DEBUG is deprecated" } if( eval { require capitalization } ) { capitalization->unimport( __PACKAGE__ ); } 1; __END__ =head1 TESTING In order to test most of the features of C, you need to provide C with a test database. For each DBI driver that you would like to test, set the environment variables C, C, and C 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 module needs to be installed in order for the test to work.) Note that the C driver will automatically be tested if C 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 Best Practical Solutions, LLC Emodules@bestpractical.comE =head1 BUGS All bugs should be reported via email to L or via the web at L. =head1 LICENSE AND COPYRIGHT Copyright (C) 2001-2014, Best Practical Solutions LLC. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO DBIx::SearchBuilder::Handle, DBIx::SearchBuilder::Record. =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Record/000755 000765 000024 00000000000 14123431630 023073 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Handle/000755 000765 000024 00000000000 14123431630 023050 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Unique.pm000644 000765 000024 00000003207 13275205765 023502 0ustar00sunnavystaff000000 000000 package DBIx::SearchBuilder::Unique; use base 'Exporter'; our @EXPORT = qw(AddRecord); our $VERSION = "0.01"; use strict; use warnings; sub AddRecord { my $self = shift; my $record = shift; # We're a mixin, so we can't override _CleanSlate, but if an object # gets reused, we need to clean ourselves out. If there are no items, # we're clearly doing a new search $self->{"dbix_sb_unique_cache"} = {} unless (@{$self->{'items'}}[0]); return if $self->{"dbix_sb_unique_cache"}->{$record->id}++; push @{$self->{'items'}}, $record; } 1; =head1 NAME DBIx::SearchBuilder::Unique - Ensure uniqueness of records in a collection =head1 SYNOPSIS package Foo::Collection; use base 'DBIx::SearchBuilder'; use DBIx::SearchBuilder::Unique; # mixin my $collection = Foo::Collection->New(); $collection->SetupComplicatedJoins; $collection->OrderByMagic; while (my $thing = $collection->Next) { # $thing is going to be distinct } =head1 DESCRIPTION Currently, DBIx::SearchBuilder makes exceptions for databases which cannot handle both C =cut sub DatabaseVersion { my $self = shift; my %args = ( Short => 1, @_ ); unless ( defined $self->{'database_version'} ) { # turn off error handling, store old values to restore later my $re = $self->RaiseError; $self->RaiseError(0); my $pe = $self->PrintError; $self->PrintError(0); my $statement = "SELECT VERSION()"; my $sth = $self->SimpleQuery($statement); my $ver = ''; $ver = ( $sth->fetchrow_arrayref->[0] || '' ) if $sth; $ver =~ /(\d+(?:\.\d+)*(?:-[a-z0-9]+)?)/i; $self->{'database_version'} = $ver; $self->{'database_version_short'} = $1 || $ver; $self->RaiseError($re); $self->PrintError($pe); } return $self->{'database_version_short'} if $args{'Short'}; return $self->{'database_version'}; } =head2 CaseSensitive Returns 1 if the current database's searches are case sensitive by default Returns undef otherwise =cut sub CaseSensitive { my $self = shift; return(1); } =head2 QuoteTableNames Returns 1 if table names will be quoted in queries, otherwise 0 =cut sub QuoteTableNames { return shift->{'QuoteTableNames'} } =head2 _MakeClauseCaseInsensitive FIELD OPERATOR VALUE Takes a field, operator and value. performs the magic necessary to make your database treat this clause as case insensitive. Returns a FIELD OPERATOR VALUE triple. =cut our $RE_CASE_INSENSITIVE_CHARS = qr/[-'"\d: ]/; sub _MakeClauseCaseInsensitive { my $self = shift; my $field = shift; my $operator = shift; my $value = shift; # don't downcase integer values and things that looks like dates if ($value !~ /^$RE_CASE_INSENSITIVE_CHARS+$/o) { $field = "lower($field)"; $value = lc($value); } return ($field, $operator, $value,undef); } =head2 Transactions L emulates nested transactions, by keeping a transaction stack depth. B In nested transactions you shouldn't mix rollbacks and commits, because only last action really do commit/rollback. For example next code would produce desired results: $handle->BeginTransaction; $handle->BeginTransaction; ... $handle->Rollback; $handle->BeginTransaction; ... $handle->Commit; $handle->Commit; Only last action(Commit in example) finilize transaction in DB. =head3 BeginTransaction Tells DBIx::SearchBuilder to begin a new SQL transaction. This will temporarily suspend Autocommit mode. =cut sub BeginTransaction { my $self = shift; my $depth = $self->TransactionDepth; return unless defined $depth; $self->TransactionDepth(++$depth); return 1 if $depth > 1; return $self->dbh->begin_work; } =head3 EndTransaction [Action => 'commit'] [Force => 0] Tells to end the current transaction. Takes C argument that could be C or C, the default value is C. If C argument is true then all nested transactions would be committed or rolled back. If there is no transaction in progress then method throw warning unless action is forced. Method returns true on success or false if an error occurred. =cut sub EndTransaction { my $self = shift; my %args = ( Action => 'commit', Force => 0, @_ ); my $action = lc $args{'Action'} eq 'commit'? 'commit': 'rollback'; my $depth = $self->TransactionDepth || 0; unless ( $depth ) { unless( $args{'Force'} ) { Carp::cluck( "Attempted to $action a transaction with none in progress" ); return 0; } return 1; } else { $depth--; } $depth = 0 if $args{'Force'}; $self->TransactionDepth( $depth ); my $dbh = $self->dbh; $TRANSROLLBACK{ $dbh }{ $action }++; if ( $TRANSROLLBACK{ $dbh }{ $action eq 'commit'? 'rollback' : 'commit' } ) { warn "Rollback and commit are mixed while escaping nested transaction"; } return 1 if $depth; delete $TRANSROLLBACK{ $dbh }; if ($action eq 'commit') { return $dbh->commit; } else { DBIx::SearchBuilder::Record::Cachable->FlushCache if DBIx::SearchBuilder::Record::Cachable->can('FlushCache'); return $dbh->rollback; } } =head3 Commit [FORCE] Tells to commit the current SQL transaction. Method uses C method, read its L. =cut sub Commit { my $self = shift; $self->EndTransaction( Action => 'commit', Force => shift ); } =head3 Rollback [FORCE] Tells to abort the current SQL transaction. Method uses C method, read its L. =cut sub Rollback { my $self = shift; $self->EndTransaction( Action => 'rollback', Force => shift ); } =head3 ForceRollback Force the handle to rollback. Whether or not we're deep in nested transactions. =cut sub ForceRollback { my $self = shift; $self->Rollback(1); } =head3 TransactionDepth Returns the current depth of the nested transaction stack. Returns C if there is no connection to database. =cut sub TransactionDepth { my $self = shift; my $dbh = $self->dbh; return undef unless $dbh && $dbh->ping; if ( @_ ) { my $depth = shift; if ( $depth ) { $TRANSDEPTH{ $dbh } = $depth; } else { delete $TRANSDEPTH{ $dbh }; } } return $TRANSDEPTH{ $dbh } || 0; } =head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE starting with FIRST_ROW; =cut sub ApplyLimits { my $self = shift; my $statementref = shift; my $per_page = shift; my $first = shift; my $limit_clause = ''; if ( $per_page) { $limit_clause = " LIMIT "; if ( $first ) { $limit_clause .= $first . ", "; } $limit_clause .= $per_page; } $$statementref .= $limit_clause; } =head2 Join { Paramhash } Takes a paramhash of everything Searchbuildler::Record does plus a parameter called 'SearchBuilder' that contains a ref to a SearchBuilder object'. This performs the join. =cut sub Join { my $self = shift; my %args = ( SearchBuilder => undef, TYPE => 'normal', ALIAS1 => 'main', FIELD1 => undef, TABLE2 => undef, COLLECTION2 => undef, FIELD2 => undef, ALIAS2 => undef, EXPRESSION => undef, @_ ); my $alias; #If we're handed in an ALIAS2, we need to go remove it from the Aliases array. # Basically, if anyone generates an alias and then tries to use it in a join later, we want to be smart about # creating joins, so we need to go rip it out of the old aliases table and drop it in as an explicit join if ( $args{'ALIAS2'} ) { # this code is slow and wasteful, but it's clear. my @aliases = @{ $args{'SearchBuilder'}->{'aliases'} }; my @new_aliases; foreach my $old_alias (@aliases) { if ( $old_alias =~ /^(.*?) (\Q$args{'ALIAS2'}\E)$/ ) { $args{'TABLE2'} = $1; $alias = $2; $args{'TABLE2'} = $self->DequoteName($args{'TABLE2'}) if $self->QuoteTableNames; } else { push @new_aliases, $old_alias; } } # If we found an alias, great. let's just pull out the table and alias for the other item unless ($alias) { # if we can't do that, can we reverse the join and have it work? my $a1 = $args{'ALIAS1'}; my $f1 = $args{'FIELD1'}; $args{'ALIAS1'} = $args{'ALIAS2'}; $args{'FIELD1'} = $args{'FIELD2'}; $args{'ALIAS2'} = $a1; $args{'FIELD2'} = $f1; @aliases = @{ $args{'SearchBuilder'}->{'aliases'} }; @new_aliases = (); foreach my $old_alias (@aliases) { if ( $old_alias =~ /^(.*?) ($args{'ALIAS2'})$/ ) { $args{'TABLE2'} = $1; $alias = $2; $args{'TABLE2'} = $self->DequoteName($args{'TABLE2'}) if $self->QuoteTableNames; } else { push @new_aliases, $old_alias; } } } else { # we found alias, so NewAlias should take care of distinctness $args{'DISTINCT'} = 1 unless exists $args{'DISTINCT'}; } unless ( $alias ) { # XXX: this situation is really bug in the caller!!! return ( $self->_NormalJoin(%args) ); } $args{'SearchBuilder'}->{'aliases'} = \@new_aliases; } elsif ( $args{'COLLECTION2'} ) { # We're joining to a pre-limited collection. We need to take # all clauses in the other collection, munge 'main.' to a new # alias, apply them locally, then proceed as usual. my $collection = delete $args{'COLLECTION2'}; $alias = $args{ALIAS2} = $args{'SearchBuilder'}->_GetAlias( $collection->Table ); $args{TABLE2} = $collection->Table; eval {$collection->_ProcessRestrictions}; # RT hate # Move over unused aliases push @{$args{SearchBuilder}{aliases}}, @{$collection->{aliases}}; # Move over joins, as well for my $join (sort keys %{$collection->{left_joins}}) { my %alias = %{$collection->{left_joins}{$join}}; $alias{depends_on} = $alias if $alias{depends_on} eq "main"; $alias{criteria} = $self->_RenameRestriction( RESTRICTIONS => $alias{criteria}, NEW => $alias ); $args{SearchBuilder}{left_joins}{$join} = \%alias; } my $restrictions = $self->_RenameRestriction( RESTRICTIONS => $collection->{restrictions}, NEW => $alias ); $args{SearchBuilder}{restrictions}{$_} = $restrictions->{$_} for keys %{$restrictions}; } else { $alias = $args{'SearchBuilder'}->_GetAlias( $args{'TABLE2'} ); } $args{TABLE2} = $self->QuoteName($args{TABLE2}) if $self->QuoteTableNames; my $meta = $args{'SearchBuilder'}->{'left_joins'}{"$alias"} ||= {}; if ( $args{'TYPE'} =~ /LEFT/i ) { $meta->{'alias_string'} = " LEFT JOIN " . $args{'TABLE2'} . " $alias "; $meta->{'type'} = 'LEFT'; } else { $meta->{'alias_string'} = " JOIN " . $args{'TABLE2'} . " $alias "; $meta->{'type'} = 'NORMAL'; } $meta->{'depends_on'} = $args{'ALIAS1'}; my $criterion = $args{'EXPRESSION'} || $args{'ALIAS1'}.".".$args{'FIELD1'}; $meta->{'criteria'}{'base_criterion'} = [ { field => "$alias.$args{'FIELD2'}", op => '=', value => $criterion } ]; if ( $args{'DISTINCT'} && !defined $args{'SearchBuilder'}{'joins_are_distinct'} ) { $args{SearchBuilder}{joins_are_distinct} = 1; } elsif ( !$args{'DISTINCT'} ) { $args{SearchBuilder}{joins_are_distinct} = 0; } return ($alias); } sub _RenameRestriction { my $self = shift; my %args = ( RESTRICTIONS => undef, OLD => "main", NEW => undef, @_, ); my %return; for my $key ( keys %{$args{RESTRICTIONS}} ) { my $newkey = $key; $newkey =~ s/^\Q$args{OLD}\E\./$args{NEW}./; my @parts; for my $part ( @{ $args{RESTRICTIONS}{$key} } ) { if ( ref $part ) { my %part = %{$part}; $part{field} =~ s/^\Q$args{OLD}\E\./$args{NEW}./; $part{value} =~ s/^\Q$args{OLD}\E\./$args{NEW}./; push @parts, \%part; } else { push @parts, $part; } } $return{$newkey} = \@parts; } return \%return; } sub _NormalJoin { my $self = shift; my %args = ( SearchBuilder => undef, TYPE => 'normal', FIELD1 => undef, ALIAS1 => undef, TABLE2 => undef, FIELD2 => undef, ALIAS2 => undef, @_ ); my $sb = $args{'SearchBuilder'}; if ( $args{'TYPE'} =~ /LEFT/i ) { my $alias = $sb->_GetAlias( $args{'TABLE2'} ); my $meta = $sb->{'left_joins'}{"$alias"} ||= {}; $args{TABLE2} = $self->QuoteName($args{TABLE2}) if $self->QuoteTableNames; $meta->{'alias_string'} = " LEFT JOIN $args{'TABLE2'} $alias "; $meta->{'depends_on'} = $args{'ALIAS1'}; $meta->{'type'} = 'LEFT'; $meta->{'criteria'}{'base_criterion'} = [ { field => "$args{'ALIAS1'}.$args{'FIELD1'}", op => '=', value => "$alias.$args{'FIELD2'}", } ]; return ($alias); } else { $sb->DBIx::SearchBuilder::Limit( ENTRYAGGREGATOR => 'AND', QUOTEVALUE => 0, ALIAS => $args{'ALIAS1'}, FIELD => $args{'FIELD1'}, VALUE => $args{'ALIAS2'} . "." . $args{'FIELD2'}, @_ ); } } # this code is all hacky and evil. but people desperately want _something_ and I'm # super tired. refactoring gratefully appreciated. sub _BuildJoins { my $self = shift; my $sb = shift; $self->OptimizeJoins( SearchBuilder => $sb ); my $table = $self->{'QuoteTableNames'} ? $self->QuoteName($sb->Table) : $sb->Table; my $join_clause = join " CROSS JOIN ", ("$table main"), @{ $sb->{'aliases'} }; my %processed = map { /^\S+\s+(\S+)$/; $1 => 1 } @{ $sb->{'aliases'} }; $processed{'main'} = 1; # get a @list of joins that have not been processed yet, but depend on processed join my $joins = $sb->{'left_joins'}; while ( my @list = grep !$processed{ $_ } && (!$joins->{ $_ }{'depends_on'} || $processed{ $joins->{ $_ }{'depends_on'} }), sort keys %$joins ) { foreach my $join ( @list ) { $processed{ $join }++; my $meta = $joins->{ $join }; my $aggregator = $meta->{'entry_aggregator'} || 'AND'; $join_clause .= $meta->{'alias_string'} . " ON "; my @tmp = map { ref($_)? $_->{'field'} .' '. $_->{'op'} .' '. $_->{'value'}: $_ } map { ('(', @$_, ')', $aggregator) } sorted_values($meta->{'criteria'}); pop @tmp; $join_clause .= join ' ', @tmp; } } # here we could check if there is recursion in joins by checking that all joins # are processed if ( my @not_processed = grep !$processed{ $_ }, keys %$joins ) { die "Unsatisfied dependency chain in joins @not_processed"; } return $join_clause; } sub OptimizeJoins { my $self = shift; my %args = (SearchBuilder => undef, @_); my $joins = $args{'SearchBuilder'}->{'left_joins'}; my %processed = map { /^\S+\s+(\S+)$/; $1 => 1 } @{ $args{'SearchBuilder'}->{'aliases'} }; $processed{ $_ }++ foreach grep $joins->{ $_ }{'type'} ne 'LEFT', keys %$joins; $processed{'main'}++; my @ordered; # get a @list of joins that have not been processed yet, but depend on processed join # if we are talking about forest then we'll get the second level of the forest, # but we should process nodes on this level at the end, so we build FILO ordered list. # finally we'll get ordered list with leafes in the beginning and top most nodes at # the end. while ( my @list = grep !$processed{ $_ } && $processed{ $joins->{ $_ }{'depends_on'} }, sort keys %$joins ) { unshift @ordered, @list; $processed{ $_ }++ foreach @list; } foreach my $join ( @ordered ) { next if $self->MayBeNull( SearchBuilder => $args{'SearchBuilder'}, ALIAS => $join ); $joins->{ $join }{'alias_string'} =~ s/^\s*LEFT\s+/ /; $joins->{ $join }{'type'} = 'NORMAL'; } # here we could check if there is recursion in joins by checking that all joins # are processed } =head2 MayBeNull Takes a C and C in a hash and resturns true if restrictions of the query allow NULLs in a table joined with the ALIAS, otherwise returns false value which means that you can use normal join instead of left for the aliased table. Works only for queries have been built with L and L methods, for other cases return true value to avoid fault optimizations. =cut sub MayBeNull { my $self = shift; my %args = (SearchBuilder => undef, ALIAS => undef, @_); # if we have at least one subclause that is not generic then we should get out # of here as we can't parse subclauses return 1 if grep $_ ne 'generic_restrictions', keys %{ $args{'SearchBuilder'}->{'subclauses'} }; # build full list of generic conditions my @conditions; foreach ( grep @$_, sorted_values($args{'SearchBuilder'}->{'restrictions'}) ) { push @conditions, 'AND' if @conditions; push @conditions, '(', @$_, ')'; } # find tables that depends on this alias and add their join conditions foreach my $join ( sorted_values($args{'SearchBuilder'}->{'left_joins'}) ) { # left joins on the left side so later we'll get 1 AND x expression # which equal to x, so we just skip it next if $join->{'type'} eq 'LEFT'; next unless $join->{'depends_on'} eq $args{'ALIAS'}; my @tmp = map { ('(', @$_, ')', $join->{'entry_aggregator'}) } sorted_values($join->{'criteria'}); pop @tmp; @conditions = ('(', @conditions, ')', 'AND', '(', @tmp ,')'); } return 1 unless @conditions; # replace conditions with boolean result: 1 - allows nulls, 0 - not # all restrictions on that don't act on required alias allow nulls # otherwise only IS NULL operator foreach ( splice @conditions ) { unless ( ref $_ ) { push @conditions, $_; } elsif ( rindex( $_->{'field'}, "$args{'ALIAS'}.", 0 ) == 0 ) { # field is alias.xxx op ... and only IS op allows NULLs push @conditions, lc $_->{op} eq 'is'; } elsif ( $_->{'value'} && rindex( $_->{'value'}, "$args{'ALIAS'}.", 0 ) == 0 ) { # value is alias.xxx so it can not be IS op push @conditions, 0; } elsif ( $_->{'field'} =~ /^(?i:lower)\(\s*\Q$args{'ALIAS'}\./ ) { # handle 'LOWER(alias.xxx) OP VALUE' we use for case insensetive push @conditions, lc $_->{op} eq 'is'; } else { push @conditions, 1; } } # resturns index of closing paren by index of openning paren my $closing_paren = sub { my $i = shift; my $count = 0; for ( ; $i < @conditions; $i++ ) { if ( $conditions[$i] eq '(' ) { $count++; } elsif ( $conditions[$i] eq ')' ) { $count--; } return $i unless $count; } die "lost in parens"; }; # solve boolean expression we have, an answer is our result my $parens_count = 0; my @tmp = (); while ( defined ( my $e = shift @conditions ) ) { #print "@tmp >>>$e<<< @conditions\n"; return $e if !@conditions && !@tmp; unless ( $e ) { if ( $conditions[0] eq ')' ) { push @tmp, $e; next; } my $aggreg = uc shift @conditions; if ( $aggreg eq 'OR' ) { # 0 OR x == x next; } elsif ( $aggreg eq 'AND' ) { # 0 AND x == 0 my $close_p = $closing_paren->(0); splice @conditions, 0, $close_p + 1, (0); } else { die "unknown aggregator: @tmp $e >>>$aggreg<<< @conditions"; } } elsif ( $e eq '1' ) { if ( $conditions[0] eq ')' ) { push @tmp, $e; next; } my $aggreg = uc shift @conditions; if ( $aggreg eq 'OR' ) { # 1 OR x == 1 my $close_p = $closing_paren->(0); splice @conditions, 0, $close_p + 1, (1); } elsif ( $aggreg eq 'AND' ) { # 1 AND x == x next; } else { die "unknown aggregator: @tmp $e >>>$aggreg<<< @conditions"; } } elsif ( $e eq '(' ) { if ( $conditions[1] eq ')' ) { splice @conditions, 1, 1; } else { $parens_count++; push @tmp, $e; } } elsif ( $e eq ')' ) { die "extra closing paren: @tmp >>>$e<<< @conditions" if --$parens_count < 0; unshift @conditions, @tmp, $e; @tmp = (); } else { die "lost: @tmp >>>$e<<< @conditions"; } } return 1; } =head2 DistinctQuery STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; my $QueryHint = $sb->QueryHint; $QueryHint = $QueryHint ? " /* $QueryHint */ " : " "; # Prepend select query for DBs which allow DISTINCT on all column types. $$statementref = "SELECT" . $QueryHint . "DISTINCT main.* FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } =head2 DistinctCount STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctCount { my $self = shift; my $statementref = shift; my $sb = shift; my $QueryHint = $sb->QueryHint; $QueryHint = $QueryHint ? " /* $QueryHint */ " : " "; # Prepend select query for DBs which allow DISTINCT on all column types. $$statementref = "SELECT" . $QueryHint . "COUNT(DISTINCT main.id) FROM $$statementref"; } sub Fields { my $self = shift; my $table = lc shift; unless ( $FIELDS_IN_TABLE{$table} ) { $FIELDS_IN_TABLE{ $table } = []; my $sth = $self->dbh->column_info( undef, '', $table, '%' ) or return (); my $info = $sth->fetchall_arrayref({}); foreach my $e ( @$info ) { push @{ $FIELDS_IN_TABLE{ $table } }, $e->{'COLUMN_NAME'}; } } return @{ $FIELDS_IN_TABLE{ $table } }; } =head2 Log MESSAGE Takes a single argument, a message to log. Currently prints that message to STDERR =cut sub Log { my $self = shift; my $msg = shift; warn $msg."\n"; } =head2 SimpleDateTimeFunctions See L for details on supported functions. This method is for implementers of custom DB connectors. Returns hash reference with (function name, sql template) pairs. =cut sub SimpleDateTimeFunctions { my $self = shift; return { datetime => 'SUBSTR(?, 1, 19)', time => 'SUBSTR(?, 12, 8)', hourly => 'SUBSTR(?, 1, 13)', hour => 'SUBSTR(?, 12, 2 )', date => 'SUBSTR(?, 1, 10)', daily => 'SUBSTR(?, 1, 10)', day => 'SUBSTR(?, 9, 2 )', dayofmonth => 'SUBSTR(?, 9, 2 )', monthly => 'SUBSTR(?, 1, 7 )', month => 'SUBSTR(?, 6, 2 )', annually => 'SUBSTR(?, 1, 4 )', year => 'SUBSTR(?, 1, 4 )', }; } =head2 DateTimeFunction Takes named arguments: =over 4 =item * Field - SQL expression date/time function should be applied to. Note that this argument is used as is without any kind of quoting. =item * Type - name of the function, see supported values below. =item * Timezone - optional hash reference with From and To values, see L for details. =back Returns SQL statement. Returns NULL if function is not supported. =head3 Supported functions Type value in L is case insesitive. Spaces, underscores and dashes are ignored. So 'date time', 'DateTime' and 'date_time' are all synonyms. The following functions are supported: =over 4 =item * date time - as is, no conversion, except applying timezone conversion if it's provided. =item * time - time only =item * hourly - datetime prefix up to the hours, e.g. '2010-03-25 16' =item * hour - hour, 0 - 23 =item * date - date only =item * daily - synonym for date =item * day of week - 0 - 6, 0 - Sunday =item * day - day of month, 1 - 31 =item * day of month - synonym for day =item * day of year - 1 - 366, support is database dependent =item * month - 1 - 12 =item * monthly - year and month prefix, e.g. '2010-11' =item * year - e.g. '2023' =item * annually - synonym for year =item * week of year - 0-53, presence of zero week, 1st week meaning and whether week starts on Monday or Sunday heavily depends on database. =back =cut sub DateTimeFunction { my $self = shift; my %args = ( Field => undef, Type => '', Timezone => undef, @_ ); my $res = $args{'Field'} || '?'; if ( $args{'Timezone'} ) { $res = $self->ConvertTimezoneFunction( %{ $args{'Timezone'} }, Field => $res, ); } my $norm_type = lc $args{'Type'}; $norm_type =~ s/[ _-]//g; if ( my $template = $self->SimpleDateTimeFunctions->{ $norm_type } ) { $template =~ s/\?/$res/; $res = $template; } else { return 'NULL'; } return $res; } =head2 ConvertTimezoneFunction Generates a function applied to Field argument that converts timezone. By default converts from UTC. Examples: # UTC => Moscow $handle->ConvertTimezoneFunction( Field => '?', To => 'Europe/Moscow'); If there is problem with arguments or timezones are equal then Field returned without any function applied. Field argument is not escaped in any way, it's your job. Implementation is very database specific. To be portable convert from UTC or to UTC. Some databases have internal storage for information about timezones that should be kept up to date. Read documentation for your DB. =cut sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'}; } =head2 DateTimeIntervalFunction Generates a function to calculate interval in seconds between two dates. Takes From and To arguments which can be either scalar or a hash. Hash is processed with L. Arguments are not quoted or escaped in any way. It's caller's job. =cut sub DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); $_ = DBIx::SearchBuilder->CombineFunctionWithField(%$_) for grep ref, @args{'From', 'To'}; return $self->_DateTimeIntervalFunction( %args ); } sub _DateTimeIntervalFunction { return 'NULL' } =head2 NullsOrder Sets order of NULLs when sorting columns when called with mode, but only if DB supports it. Modes: =over 4 =item * small NULLs are smaller then anything else, so come first when order is ASC and last otherwise. =item * large NULLs are larger then anything else. =item * first NULLs are always first. =item * last NULLs are always last. =item * default Return back to DB's default behaviour. =back When called without argument returns metadata required to generate SQL. =cut sub NullsOrder { my $self = shift; unless ($self->HasSupportForNullsOrder) { warn "No support for changing NULLs order" if @_; return undef; } if ( @_ ) { my $mode = shift || 'default'; if ( $mode eq 'default' ) { delete $self->{'nulls_order'}; } elsif ( $mode eq 'small' ) { $self->{'nulls_order'} = { ASC => 'NULLS FIRST', DESC => 'NULLS LAST' }; } elsif ( $mode eq 'large' ) { $self->{'nulls_order'} = { ASC => 'NULLS LAST', DESC => 'NULLS FIRST' }; } elsif ( $mode eq 'first' ) { $self->{'nulls_order'} = { ASC => 'NULLS FIRST', DESC => 'NULLS FIRST' }; } elsif ( $mode eq 'last' ) { $self->{'nulls_order'} = { ASC => 'NULLS LAST', DESC => 'NULLS LAST' }; } else { warn "'$mode' is not supported NULLs ordering mode"; delete $self->{'nulls_order'}; } } return undef unless $self->{'nulls_order'}; return $self->{'nulls_order'}; } =head2 HasSupportForNullsOrder Returns true value if DB supports adjusting NULLs order while sorting a column, for example C. =cut sub HasSupportForNullsOrder { return 0; } =head2 QuoteName Quote table or column name to avoid reserved word errors. Returns same value passed unless over-ridden in database-specific subclass. =cut # over-ride in subclass sub QuoteName { my ($self, $name) = @_; # use dbi built in quoting if we have a connection, if ($self->dbh) { return $self->dbh->quote_identifier($name); } warn "QuoteName called without a db handle"; return $name; } =head2 DequoteName Undo the effects of QuoteName by removing quoting. =cut sub DequoteName { my ($self, $name) = @_; if ($self->dbh) { # 29 = SQL_IDENTIFIER_QUOTE_CHAR; see "perldoc DBI" my $quote_char = $self->dbh->get_info( 29 ); if ($quote_char) { if ($name =~ /^$quote_char(.*)$quote_char$/) { return $1; } } return $name; } warn "DequoteName called without a db handle"; return $name; } sub _ExtractBindValues { my $self = shift; my $string = shift; my $default_escape_char = shift || q{'}; return $string unless defined $string; my $placeholder = ''; my @chars = split //, $string; my $value = ''; my $escape_char = $default_escape_char; my @values; my $in = 0; # keep state in the loop: is it in a quote? while ( defined( my $c = shift @chars ) ) { my $escaped; if ( $c eq $escape_char && $in ) { if ( $escape_char eq q{'} ) { if ( ( $chars[0] || '' ) eq q{'} ) { $c = shift @chars; $escaped = 1; } } else { $c = shift @chars; $escaped = 1; } } if ($in) { if ( $c eq q{'} ) { if ( !$escaped ) { push @values, $value; $in = 0; $value = ''; $escape_char = $default_escape_char; $placeholder .= '?'; next; } } $value .= $c; } else { if ( $c eq q{'} ) { $in = 1; } # Handle quoted string like e'foo\\bar' elsif ( lc $c eq 'e' && ( $chars[0] // '' ) eq q{'} ) { $escape_char = '\\'; } # Handle numbers elsif ( $c =~ /[\d.]/ && $placeholder !~ /\w$/ ) { # Do not catch Groups_1.Name $value .= $c; while ( ( $chars[0] // '' ) =~ /[\d.]/ ) { $value .= shift @chars; } push @values, $value; $placeholder .= '?'; $value = ''; } else { $placeholder .= $c; } } } return ( $placeholder, @values ); } sub _RequireQuotedTables { return 0 }; =head2 DESTROY When we get rid of the Searchbuilder::Handle, we need to disconnect from the database =cut sub DESTROY { my $self = shift; $self->Disconnect if $self->{'DisconnectHandleOnDestroy'}; delete $DBIHandle{$self}; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO perl(1), L =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/SchemaGenerator.pm000644 000765 000024 00000020714 13275205765 025305 0ustar00sunnavystaff000000 000000 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 object. The single required argument is a C. =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, or the name of such a subclass; in the latter case, C will instantiate an object of the subclass. The model must define the instance methods C and C. Returns true if the model was added successfully; returns a false C 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 containing 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 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. 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@rt.cpan.org>, or through the web interface at L. =head1 AUTHOR David Glasser C<< glasser@bestpractical.com >> =head1 LICENCE AND COPYRIGHT Copyright (c) , C<< <> >>. 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. =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. DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Record.pm000755 000765 000024 00000106064 14112776367 023464 0ustar00sunnavystaff000000 000000 package DBIx::SearchBuilder::Record; use strict; use warnings; use vars qw($AUTOLOAD); use Class::ReturnValue; use Encode qw(); use DBIx::SearchBuilder::Util qw/ sorted_values /; =head1 NAME DBIx::SearchBuilder::Record - Superclass for records loaded by SearchBuilder =head1 SYNOPSIS package MyRecord; use base qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $DBIxHandle = shift; # A DBIx::SearchBuilder::Handle::foo object for your database $self->_Handle($DBIxHandle); $self->Table("Users"); } # Tell Record what the primary keys are sub _PrimaryKeys { return ['id']; } # Preferred and most efficient way to specify fields attributes in a derived # class, used by the autoloader to construct Attrib and SetAttrib methods. # read: calling $Object->Foo will return the value of this record's Foo column # write: calling $Object->SetFoo with a single value will set Foo's value in # both the loaded object and the database sub _ClassAccessible { { Tofu => { 'read' => 1, 'write' => 1 }, Maz => { 'auto' => 1, }, Roo => { 'read' => 1, 'auto' => 1, 'public' => 1, }, }; } # A subroutine to check a user's password without returning the current value # For security purposes, we didn't expose the Password method above sub IsPassword { my $self = shift; my $try = shift; # note two __s in __Value. Subclasses may muck with _Value, but # they should never touch __Value if ( $try eq $self->__Value('Password') ) { return (1); } else { return (undef); } } # Override DBIx::SearchBuilder::Create to do some checking on create sub Create { my $self = shift; my %fields = ( UserId => undef, Password => 'default', #Set a default password @_ ); # Make sure a userid is specified unless ( $fields{'UserId'} ) { die "No userid specified."; } # Get DBIx::SearchBuilder::Record->Create to do the real work return ( $self->SUPER::Create( UserId => $fields{'UserId'}, Password => $fields{'Password'}, Created => time ) ); } =head1 DESCRIPTION DBIx::SearchBuilder::Record is designed to work with DBIx::SearchBuilder. =head2 What is it trying to do. DBIx::SearchBuilder::Record abstracts the agony of writing the common and generally simple SQL statements needed to serialize and De-serialize an object to the database. In a traditional system, you would define various methods on your object 'create', 'find', 'modify', and 'delete' being the most common. In each method you would have a SQL statement like: select * from table where value='blah'; If you wanted to control what data a user could modify, you would have to do some special magic to make accessors do the right thing. Etc. The problem with this approach is that in a majority of the cases, the SQL is incredibly simple and the code from one method/object to the next was basically the same. Enter, DBIx::SearchBuilder::Record. With Record, you can in the simple case, remove all of that code and replace it by defining two methods and inheriting some code. It's pretty simple, and incredibly powerful. For more complex cases, you can do more complicated things by overriding certain methods. Let's stick with the simple case for now. The two methods in question are L and L. All they really do are define some values and send you on your way. As you might have guessed the '_' means that these are private methods. They will get called by your record object's constructor. =over 4 =item '_Init' Defines what table we are talking about, and set a variable to store the database handle. =item '_ClassAccessible Defines what operations may be performed on various data selected from the database. For example you can define fields to be mutable, or immutable, there are a few other options but I don't understand what they do at this time. =back And really, that's it. So let's have some sample code. =head2 An Annotated Example The example code below makes the following assumptions: =over 4 =item * The database is 'postgres', =item * The host is 'reason', =item * The login name is 'mhat', =item * The database is called 'example', =item * The table is called 'simple', =item * The table looks like so: id integer not NULL, primary_key(id), foo varchar(10), bar varchar(10) =back First, let's define our record class in a new module named "Simple.pm". 000: package Simple; 001: use DBIx::SearchBuilder::Record; 002: @ISA = (DBIx::SearchBuilder::Record); This should be pretty obvious, name the package, import ::Record and then define ourself as a subclass of ::Record. 003: 004: sub _Init { 005: my $this = shift; 006: my $handle = shift; 007: 008: $this->_Handle($handle); 009: $this->Table("Simple"); 010: 011: return ($this); 012: } Here we set our handle and table name, while its not obvious so far, we'll see later that $handle (line: 006) gets passed via ::Record::new when a new instance is created. That's actually an important concept: the DB handle is not bound to a single object but rather, it is shared across objects. 013: 014: sub _ClassAccessible { 015: { 016: Foo => { 'read' => 1 }, 017: Bar => { 'read' => 1, 'write' => 1 }, 018: Id => { 'read' => 1 } 019: }; 020: } What's happening might be obvious, but just in case this method is going to return a reference to a hash. That hash is where our columns are defined, as well as what type of operations are acceptable. 021: 022: 1; Like all perl modules, this needs to end with a true value. Now, on to the code that will actually *do* something with this object. This code would be placed in your Perl script. 000: use DBIx::SearchBuilder::Handle; 001: use Simple; Use two packages, the first is where I get the DB handle from, the latter is the object I just created. 002: 003: my $handle = DBIx::SearchBuilder::Handle->new(); 004: $handle->Connect( 'Driver' => 'Pg', 005: 'Database' => 'test', 006: 'Host' => 'reason', 007: 'User' => 'mhat', 008: 'Password' => ''); Creates a new DBIx::SearchBuilder::Handle, and then connects to the database using that handle. Pretty straight forward, the password '' is what I use when there is no password. I could probably leave it blank, but I find it to be more clear to define it. 009: 010: my $s = Simple->new($handle); 011: 012: $s->LoadById(1); LoadById is one of four 'LoadBy' methods, as the name suggests it searches for an row in the database that has id='0'. ::SearchBuilder has, what I think is a bug, in that it current requires there to be an id field. More reasonably it also assumes that the id field is unique. LoadById($id) will do undefined things if there is >1 row with the same id. In addition to LoadById, we also have: =over 4 =item LoadByCol Takes two arguments, a column name and a value. Again, it will do undefined things if you use non-unique things. =item LoadByCols Takes a hash of columns=>values and returns the *first* to match. First is probably lossy across databases vendors. =item LoadFromHash Populates this record with data from a DBIx::SearchBuilder. I'm currently assuming that DBIx::SearchBuilder is what we use in cases where we expect > 1 record. More on this later. =back Now that we have a populated object, we should do something with it! ::Record automagically generates accessos and mutators for us, so all we need to do is call the methods. Accessors are named (), and Mutators are named Set($). On to the example, just appending this to the code from the last example. 013: 014: print "ID : ", $s->Id(), "\n"; 015: print "Foo : ", $s->Foo(), "\n"; 016: print "Bar : ", $s->Bar(), "\n"; That's all you have to to get the data. Now to change the data! 017: 018: $s->SetBar('NewBar'); Pretty simple! That's really all there is to it. Set($) returns a boolean and a string describing the problem. Let's look at an example of what will happen if we try to set a 'Id' which we previously defined as read only. 019: my ($res, $str) = $s->SetId('2'); 020: if (! $res) { 021: ## Print the error! 022: print "$str\n"; 023: } The output will be: >> Immutable field Currently Set updates the data in the database as soon as you call it. In the future I hope to extend ::Record to better support transactional operations, such that updates will only happen when "you" say so. Finally, adding a removing records from the database. ::Record provides a Create method which simply takes a hash of key=>value pairs. The keys exactly map to database fields. 023: ## Get a new record object. 024: $s1 = Simple->new($handle); 025: $s1->Create('Id' => 4, 026: 'Foo' => 'Foooooo', 027: 'Bar' => 'Barrrrr'); Poof! A new row in the database has been created! Now let's delete the object! 028: 029: $s1 = undef; 030: $s1 = Simple->new($handle); 031: $s1->LoadById(4); 032: $s1->Delete(); And it's gone. For simple use, that's more or less all there is to it. In the future, we hope to expand this how-to to discuss using container classes, overloading, etc. =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 Instantiate a new record object. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless ($self, $class); $self->_Init(@_); return $self; } # Not yet documented here. Should almost certainly be overloaded. sub _Init { my $self = shift; my $handle = shift; $self->_Handle($handle); } =head2 id Returns this row's primary key. =cut *id = \&Id; sub Id { my $pkey = $_[0]->_PrimaryKey(); return $_[0]->{'values'}->{ $pkey }; } =head2 primary_keys =head2 PrimaryKeys Return a hash of the values of our primary keys for this function. =cut sub PrimaryKeys { my $self = shift; return map { $_ => $self->{'values'}->{lc $_} } @{$self->_PrimaryKeys}; } sub DESTROY { return 1; } sub AUTOLOAD { my $self = $_[0]; no strict 'refs'; my ($Attrib) = ( $AUTOLOAD =~ /::(\w+)$/o ); if ( $self->_Accessible( $Attrib, 'read' ) ) { *{$AUTOLOAD} = sub { return ( $_[0]->_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; 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; $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' ) }; goto &$AUTOLOAD; } else { return ( 0, 'Nonexistant field?' ); } } elsif ( $AUTOLOAD =~ /.*::(\w+?)_?[oO]bj$/o ) { $Attrib = $1; if ( $self->_Accessible( $Attrib, 'object' ) ) { *{$AUTOLOAD} = sub { return (shift)->_Object( Field => $Attrib, Args => [@_], ); }; goto &$AUTOLOAD; } else { return ( 0, 'No object mapping for field' ); } } #Previously, I checked for writability here. but I'm not sure that's the #right idea. it breaks the ability to do ValidateQueue for a ticket #on creation. elsif ( $AUTOLOAD =~ /.*::[vV]alidate_?(\w+)/o ) { $Attrib = $1; *{$AUTOLOAD} = sub { return ( $_[0]->_Validate( $Attrib, $_[1] ) ) }; goto &$AUTOLOAD; } # TODO: if autoload = 0 or 1 _ then a combination of lowercase and _ chars, # turn them into studlycapped phrases else { my ( $package, $filename, $line ); ( $package, $filename, $line ) = caller; die "$AUTOLOAD Unimplemented in $package. ($filename line $line) \n"; } } =head2 _Accessible KEY MODE Private method. Returns undef unless C is accessible in C otherwise returns C value =cut sub _Accessible { my $self = shift; my $attr = shift; my $mode = lc(shift || ''); my $attribute = $self->_ClassAccessible(@_)->{$attr}; return unless defined $attribute; return $attribute->{$mode}; } =head2 _PrimaryKeys Return our primary keys. (Subclasses should override this, but our default is that we have one primary key, named 'id'.) =cut sub _PrimaryKeys { my $self = shift; return ['id']; } sub _PrimaryKey { my $self = shift; my $pkeys = $self->_PrimaryKeys(); die "No primary key" unless ( ref($pkeys) eq 'ARRAY' and $pkeys->[0] ); die "Too many primary keys" unless ( scalar(@$pkeys) == 1 ); return $pkeys->[0]; } =head2 _ClassAccessible An older way to specify fields attributes in a derived class. (The current preferred method is by overriding C; if you do this and don't override C<_ClassAccessible>, the module will generate an appropriate C<_ClassAccessible> based on your C.) Here's an example declaration: sub _ClassAccessible { { Tofu => { 'read'=>1, 'write'=>1 }, Maz => { 'auto'=>1, }, Roo => { 'read'=>1, 'auto'=>1, 'public'=>1, }, }; } =cut 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 foreach split(/[\/,]/, shift); } 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 =head2 ReadableAttributes Returns an array of the attributes of this class defined as "read" => 1 in this class' _ClassAccessible datastructure =cut sub ReadableAttributes { my $self = shift; my $ca = $self->_ClassAccessible(); my @readable = grep { $ca->{$_}->{'read'} or $ca->{$_}->{'record-read'} } sort keys %{$ca}; return (@readable); } =head2 WritableAttributes Returns an array of the attributes of this class defined as "write" => 1 in this class' _ClassAccessible datastructure =cut sub WritableAttributes { my $self = shift; my $ca = $self->_ClassAccessible(); my @writable = grep { $ca->{$_}->{'write'} || $ca->{$_}->{'record-write'} } sort keys %{$ca}; return @writable; } =head2 __Value Takes a field name and returns that field's value. Subclasses should never override __Value. =cut sub __Value { my $self = shift; my $field = lc shift; $field = $self->_Accessible($field, "column") || $field; return $self->{'values'}{$field} if $self->{'fetched'}{$field}; $self->{'fetched'}{$field} = 1; my %pk = $self->PrimaryKeys; return undef if grep !defined, values %pk; my $query = "SELECT $field FROM ". $self->QuotedTableName ." WHERE ". join " AND ", map "$_ = ?", sort keys %pk; my $sth = $self->_Handle->SimpleQuery( $query, sorted_values(%pk) ) or return undef; return $self->{'values'}{$field} = ($sth->fetchrow_array)[0]; } =head2 _Value _Value takes a single column name and returns that column's value for this row. Subclasses can override _Value to insert custom access control. =cut sub _Value { my $self = shift; return ($self->__Value(@_)); } =head2 _Set _Set takes a single column name and a single unquoted value. It updates both the in-memory value of this column and the in-database copy. Subclasses can override _Set to insert custom access control. =cut sub _Set { my $self = shift; return ($self->__Set(@_)); } sub __Set { my $self = shift; my %args = ( 'Field' => undef, 'Value' => undef, 'IsSQL' => undef, @_ ); $args{'Column'} = delete $args{'Field'}; $args{'IsSQLFunction'} = delete $args{'IsSQL'}; my $ret = Class::ReturnValue->new(); unless ( $args{'Column'} ) { $ret->as_array( 0, 'No column specified' ); $ret->as_error( errno => 5, do_backtrace => 0, message => "No column specified" ); return ( $ret->return_value ); } my $column = lc $args{'Column'}; # XXX: OLD behaviour, no_undefs_in_set will go away if ( !defined $args{'Value'} && $self->{'no_undefs_in_set' } ) { $ret->as_array( 0, "No value passed to _Set" ); $ret->as_error( errno => 2, do_backtrace => 0, message => "No value passed to _Set" ); return ( $ret->return_value ); } if ( defined $args{'Value'} ) { if ( $args{'Value'} eq '' && ( $self->_Accessible( $args{'Column'}, 'is_numeric' ) || ($self->_Accessible( $args{'Column'}, 'type' ) || '') =~ /INT/i ) ) { $args{'Value'} = 0; } } else { if ( $self->_Accessible( $args{Column}, 'no_nulls' ) ) { my $default = $self->_Accessible( $args{Column}, 'default' ); if ( defined $default ) { $args{'Value'} = $default; } else { $ret->as_array( 0, 'Illegal value for non-nullable field ' . $args{'Column'} . ": undef/null value provided and no default specified by class" ); $ret->as_error( errno => 3, do_backtrace => 0, message => "Illegal value for non-nullable field " . $args{'Column'} . ": undef/null value provided and no default specified by class" ); return ( $ret->return_value ); } } } my $current_value = $self->__Value($column); if ( ( !defined $args{'Value'} && !defined $current_value ) || ( defined $args{'Value'} && defined $current_value && ( $args{'Value'} eq $current_value ) ) ) { $ret->as_array( 0, "That is already the current value" ); $ret->as_error( errno => 1, do_backtrace => 0, message => "That is already the current value" ); return ( $ret->return_value ); } # First, we truncate the value, if we need to. # $args{'Value'} = $self->TruncateValue ( $args{'Column'}, $args{'Value'}); my $method = "Validate" . $args{'Column'}; unless ( $self->$method( $args{'Value'} ) ) { $ret->as_array( 0, 'Illegal value for ' . $args{'Column'} ); $ret->as_error( errno => 3, do_backtrace => 0, message => "Illegal value for " . $args{'Column'} ); return ( $ret->return_value ); } $args{'Table'} = $self->Table(); $args{'PrimaryKeys'} = { $self->PrimaryKeys() }; # The blob handling will destroy $args{'Value'}. But we assign # that back to the object at the end. this works around that my $unmunged_value = $args{'Value'}; unless ( $self->_Handle->KnowsBLOBs ) { # Support for databases which don't deal with LOBs automatically my $ca = $self->_ClassAccessible(); my $key = $args{'Column'}; if ( $ca->{$key}->{'type'} =~ /^(text|longtext|clob|blob|lob)$/i ) { my $bhash = $self->_Handle->BLOBParams( $key, $ca->{$key}->{'type'} ); $bhash->{'value'} = $args{'Value'}; $args{'Value'} = $bhash; } } my $val = $self->_Handle->UpdateRecordValue(%args); unless ($val) { my $message = $args{'Column'} . " could not be set to " . ( defined $args{'Value'} ? $args{'Value'} : 'undef' ) . "."; $ret->as_array( 0, $message); $ret->as_error( errno => 4, do_backtrace => 0, message => $message ); return ( $ret->return_value ); } # If we've performed some sort of "functional update" # then we need to reload the object from the DB to know what's # really going on. (ex SET Cost = Cost+5) if ( $args{'IsSQLFunction'} ) { $self->Load( $self->Id ); } else { $self->{'values'}->{"$column"} = $unmunged_value; } $ret->as_array( 1, "The new value has been 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 { my $self = shift; my $field = shift; my $value = shift; #Check type of input #If it's null, are nulls permitted? #If it's an int, check the # of bits #If it's a string, #check length #check for nonprintables #If it's a blob, check for length #In an ideal world, if this is a link to another table, check the dependency. return(1); } =head2 TruncateValue KEY VALUE Truncate a value that's about to be set so that it will fit inside the database' s idea of how big the column is. (Actually, it looks at SearchBuilder's concept of the database, not directly into the db). =cut sub TruncateValue { my $self = shift; my $key = shift; my $value = shift; # We don't need to truncate empty things. return undef unless defined $value; my $metadata = $self->_ClassAccessible->{$key}; return $value unless $metadata; my $truncate_to; if ( $metadata->{'length'} && !$metadata->{'is_numeric'} ) { $truncate_to = int $metadata->{'length'}; } elsif ($metadata->{'type'} && $metadata->{'type'} =~ /char\((\d+)\)/ ) { $truncate_to = $1; } return $value unless $truncate_to; # return asap if length in bytes is smaller than limit return $value if $truncate_to >= do { use bytes; length $value }; if ( Encode::is_utf8($value) ) { return Encode::decode_utf8( substr( Encode::encode_utf8( $value ), 0, $truncate_to ), Encode::FB_QUIET(), ); } else { # XXX: if it's not UTF-8 then why do we convert it to? return Encode::encode_utf8( Encode::decode_utf8 ( substr( $value, 0, $truncate_to ), Encode::FB_QUIET(), ) ); } } =head2 _Object _Object takes a single column name and an array reference. It creates new object instance of class specified in _ClassAccessable structure and calls LoadById on recently created object with the current column value as argument. It uses the array reference as the object constructor's arguments. Subclasses can override _Object to insert custom access control or define default constructor arguments. Note that if you are using a C with a C field, this is unnecessary: the method to access the column's value will automatically turn it into the appropriate object. =cut sub _Object { my $self = shift; return $self->__Object(@_); } sub __Object { my $self = shift; my %args = ( Field => '', Args => [], @_ ); my $field = $args{'Field'}; my $class = $self->_Accessible( $field, 'object' ); # Globs magic to be sure that we call 'eval "require $class"' only once # because eval is quite slow -- cubic@acronis.ru no strict qw( refs ); my $vglob = ${ $class . '::' }{'VERSION'}; unless ( $vglob && *$vglob{'SCALAR'} ) { eval "require $class"; die "Couldn't use $class: $@" if ($@); unless ( $vglob && *$vglob{'SCALAR'} ) { *{ $class . "::VERSION" } = '-1, By DBIx::SearchBuilder'; } } my $object = $class->new( @{ $args{'Args'} } ); $object->LoadById( $self->__Value($field) ); return $object; } # load should do a bit of overloading # if we call it with only one argument, we're trying to load by reference. # if we call it with a passel of arguments, we're trying to load by value # The latter is primarily important when we've got a whole set of record that we're # reading in with a recordset class and want to instantiate objefcts for each record. =head2 Load Takes a single argument, $id. Calls LoadById to retrieve the row whose primary key is $id =cut sub Load { my $self = shift; return $self->LoadById(@_); } =head2 LoadByCol Takes two arguments, a column and a value. The column can be any table column which contains unique values. Behavior when using a non-unique value is undefined =cut sub LoadByCol { my $self = shift; return $self->LoadByCols(@_); } =head2 LoadByCols Takes a hash of columns and values. Loads the first record that matches all keys. The hash's keys are the columns to look at. The hash's values are either: scalar values to look for OR has references which contain 'operator' and 'value' =cut sub LoadByCols { my $self = shift; my %hash = (@_); my (@bind, @phrases); foreach my $key (sort keys %hash) { if (defined $hash{$key} && $hash{$key} ne '') { my $op; my $value; my $function = "?"; if (ref $hash{$key} eq 'HASH') { $op = $hash{$key}->{operator}; $value = $hash{$key}->{value}; $function = $hash{$key}->{function} || "?"; } else { $op = '='; $value = $hash{$key}; } push @phrases, "$key $op $function"; push @bind, $value; } else { 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, ''; } } } my $QueryString = "SELECT * FROM ".$self->QuotedTableName." WHERE ". join(' AND ', @phrases) ; return ($self->_LoadFromSQL($QueryString, @bind)); } =head2 LoadById Loads a record by its primary key. Your record class must define a single primary key column. =cut sub LoadById { my ($self, $id) = @_; return $self->LoadByCols( $self->_PrimaryKey, defined $id? $id: 0 ); } =head2 LoadByPrimaryKeys Like LoadById with basic support for compound primary keys. =cut sub LoadByPrimaryKeys { my $self = shift; my $data = (ref $_[0] eq 'HASH')? $_[0]: {@_}; my %cols=(); foreach (@{$self->_PrimaryKeys}) { return (0, "Missing PK field: '$_'") unless defined $data->{$_}; $cols{$_}=$data->{$_}; } return ($self->LoadByCols(%cols)); } =head2 LoadFromHash Takes a hashref, such as created by DBIx::SearchBuilder and populates this record's loaded values hash. =cut sub LoadFromHash { my $self = shift; my $hashref = shift; foreach my $f ( keys %$hashref ) { $self->{'fetched'}{lc $f} = 1; } $self->{'values'} = $hashref; return $self->id(); } =head2 _LoadFromSQL QUERYSTRING @BIND_VALUES Load a record as the result of an SQL statement =cut sub _LoadFromSQL { my $self = shift; my $QueryString = shift; my @bind_values = (@_); my $sth = $self->_Handle->SimpleQuery( $QueryString, @bind_values ); #TODO this only gets the first row. we should check if there are more. return ( 0, "Couldn't execute query: ".$self->_Handle->dbh->errstr ) unless $sth; $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" ); } ## I guess to be consistant with the old code, make sure the primary ## keys exist. 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" ); } =head2 Create Takes an array of key-value pairs and drops any keys that aren't known as columns for this recordtype =cut sub Create { my $self = shift; my %attribs = @_; my ($key); foreach $key ( keys %attribs ) { if ( $self->_Accessible( $key, 'record-write' ) ) { $attribs{$key} = $attribs{$key}->id if UNIVERSAL::isa( $attribs{$key}, 'DBIx::SearchBuilder::Record' ); } if ( defined $attribs{$key} ) { if ( $attribs{$key} eq '' && ( $self->_Accessible( $key, 'is_numeric' ) || ($self->_Accessible( $key, 'type' ) || '') =~ /INT/i ) ) { $attribs{$key} = 0; } } else { $attribs{$key} = $self->_Accessible( $key, 'default' ) if $self->_Accessible( $key, 'no_nulls' ); } #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 ) { my $type = $ca->{$key}->{'type'}; next unless $type && $type =~ /^(text|longtext|clob|blob|lob)$/i; my $bhash = $self->_Handle->BLOBParams( $key, $type ); $bhash->{'value'} = $attribs{$key}; $attribs{$key} = $bhash; } } return ( $self->_Handle->Insert( $self->Table, %attribs ) ); } =head2 Delete Delete this record from the database. On failure return a Class::ReturnValue with the error. On success, return 1; =cut *delete = \&Delete; sub Delete { $_[0]->__Delete; } sub __Delete { my $self = shift; #TODO Check to make sure the key's not already listed. #TODO Update internal data structure ## Constructs the where clause. my @bind=(); my %pkeys=$self->PrimaryKeys(); my $where = 'WHERE '; foreach my $key (sort keys %pkeys) { $where .= $key . "=?" . " AND "; push (@bind, $pkeys{$key}); } $where =~ s/AND\s$//; my $QueryString = "DELETE FROM ". $self->QuotedTableName . ' ' . $where; my $return = $self->_Handle->SimpleQuery($QueryString, @bind); if (UNIVERSAL::isa($return, 'Class::ReturnValue')) { return ($return); } else { return(1); } } =head2 Table Returns or sets the name of the current Table =cut sub Table { my $self = shift; if (@_) { $self->{'table'} = shift; } return ($self->{'table'}); } =head2 QuotedTableName Returns the name of current Table, or the table provided as an argument, including any quoting based on yje Handle's QuoteTableNames flag and driver method. =cut sub QuotedTableName { my ($self, $name) = @_; unless ($name) { return $self->{'_quoted_table'} if defined $self->{'_quoted_table'}; $self->{'_quoted_table'} = $self->_Handle->QuoteTableNames ? $self->_Handle->QuoteName( $self->Table ) : $self->Table; return $self->{'_quoted_table'}; } return $self->_Handle->QuoteTableNames ? $self->_Handle->QuoteName($name) : $name; } =head2 _Handle Returns or sets the current DBIx::SearchBuilder::Handle object =cut sub _Handle { my $self = shift; if (@_) { $self->{'DBIxHandle'} = shift; } return ($self->{'DBIxHandle'}); } if( eval { require capitalization } ) { capitalization->unimport( __PACKAGE__ ); } 1; __END__ =head1 AUTHOR Jesse Vincent, Enhancements by Ivan Kohler, Docs by Matt Knopp =head1 SEE ALSO L =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Union.pm000644 000765 000024 00000010350 13275205765 023321 0ustar00sunnavystaff000000 000000 package DBIx::SearchBuilder::Union; use strict; use warnings; # WARNING --- This is still development code. It is experimental. our $VERSION = '0'; # This could inherit from DBIx::SearchBuilder, but there are _a lot_ # of things in DBIx::SearchBuilder that we don't want, like Limit and # stuff. It probably makes sense to (eventually) split out # DBIx::SearchBuilder::Collection to contain all the iterator logic. # This could inherit from that. =head1 NAME DBIx::SearchBuilder::Union - Deal with multiple SearchBuilder result sets as one =head1 SYNOPSIS use DBIx::SearchBuilder::Union; my $U = new DBIx::SearchBuilder::Union; $U->add( $tickets1 ); $U->add( $tickets2 ); $U->GotoFirstItem; while (my $z = $U->Next) { printf "%5d %30.30s\n", $z->Id, $z->Subject; } =head1 WARNING This module is still experimental. =head1 DESCRIPTION Implements a subset of the DBIx::SearchBuilder collection methods, but enough to do iteration over a bunch of results. Useful for displaying the results of two unrelated searches (for the same kind of objects) in a single list. =head1 METHODS =head2 new Create a new DBIx::SearchBuilder::Union object. No arguments. =cut sub new { bless { data => [], curp => 0, # current offset in data item => 0, # number of indiv items from First count => undef, }, shift; } =head2 add $sb Add a searchbuilder result (collection) to the Union object. It must be the same type as the first object added. =cut sub add { my $self = shift; my $newobj = shift; unless ( @{$self->{data}} == 0 || ref($newobj) eq ref($self->{data}[0]) ) { die "All elements of a DBIx::SearchBuilder::Union must be of the same type. Looking for a " . ref($self->{data}[0]) ."."; } $self->{count} = undef; push @{$self->{data}}, $newobj; } =head2 First Return the very first element of the Union (which is the first element of the first Collection). Also reset the current pointer to that element. =cut sub First { my $self = shift; die "No elements in DBIx::SearchBuilder::Union" unless @{$self->{data}}; $self->{curp} = 0; $self->{item} = 0; $self->{data}[0]->First; } =head2 Next Return the next element in the Union. =cut sub Next { my $self=shift; my $goto_first = 0; while ( my $cur = $self->{'data'}[ $self->{'curp'} ] ) { $cur->GotoFirstItem if $goto_first; my $res = $cur->Next; if ( $res ) { $self->{'item'}++; return $res; } $goto_first = 1; $self->{'curp'}++; } return undef; } =head2 Last Returns the last item =cut sub Last { die "Last doesn't work right now"; my $self = shift; $self->GotoItem( ( $self->Count ) - 1 ); return ( $self->Next ); } =head2 Count Returns the total number of elements in the Union'ed Collection =cut sub Count { my $self = shift; my $sum = 0; # cache the results return $self->{count} if defined $self->{count}; $sum += $_->Count for (@{$self->{data}}); $self->{count} = $sum; return $sum; } =head2 GotoFirstItem Starts the recordset counter over from the first item. the next time you call Next, you'll get the first item returned by the database, as if you'd just started iterating through the result set. =cut sub GotoFirstItem { my $self = shift; $self->GotoItem(0); } sub GotoItem { my $self = shift; my $item = shift; die "We currently only support going to the First item" unless $item == 0; $self->{curp} = 0; $self->{item} = 0; $self->{data}[0]->GotoItem(0); return $item; } =head2 IsLast Returns true if the current row is the last record in the set. =cut sub IsLast { my $self = shift; $self->{item} == $self->Count ? 1 : undef; } =head2 ItemsArrayRef Return a refernece to an array containing all objects found by this search. Will destroy any positional state. =cut sub ItemsArrayRef { my $self = shift; return [] unless $self->Count; $self->GotoFirstItem(); my @ret; while( my $r = $self->Next ) { push @ret, $r; } return \@ret; } =head1 AUTHOR Copyright (c) 2004 Robert Spier All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO DBIx::SearchBuilder =cut 1; __END__ DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Handle/ODBC.pm000644 000765 000024 00000003344 13275205765 024140 0ustar00sunnavystaff000000 000000 # $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/ODBC.pm,v 1.8 2001/10/12 05:27:05 jesse Exp $ package DBIx::SearchBuilder::Handle::ODBC; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::ODBC - An ODBC specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of ODBC. =head1 METHODS =cut =head2 CaseSensitive Returns a false value. =cut sub CaseSensitive { my $self = shift; return (undef); } =head2 BuildDSN =cut sub BuildDSN { my $self = shift; my %args = ( Driver => undef, Database => undef, Host => undef, Port => undef, @_ ); my $dsn = "dbi:$args{'Driver'}:$args{'Database'}"; $dsn .= ";host=$args{'Host'}" if (defined $args{'Host'} && $args{'Host'}); $dsn .= ";port=$args{'Port'}" if (defined $args{'Port'} && $args{'Port'}); $self->{'dsn'} = $dsn; } =head2 ApplyLimits =cut sub ApplyLimits { my $self = shift; my $statementref = shift; my $per_page = shift or return; my $first = shift; my $limit_clause = " TOP $per_page"; $limit_clause .= " OFFSET $first" if $first; $$statementref =~ s/SELECT\b/SELECT $limit_clause/; } =head2 DistinctQuery =cut sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; $$statementref = "SELECT main.* FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } sub Encoding { } 1; __END__ =head1 AUTHOR Autrijus Tang =head1 SEE ALSO DBIx::SearchBuilder, DBIx::SearchBuilder::Handle =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Handle/Pg.pm000755 000765 000024 00000022350 14107656677 024007 0ustar00sunnavystaff000000 000000 #$Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/Pg.pm,v 1.8 2001/07/27 05:23:29 jesse Exp $ # Copyright 1999-2001 Jesse Vincent package DBIx::SearchBuilder::Handle::Pg; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); use Want qw(howmany); =head1 NAME DBIx::SearchBuilder::Handle::Pg - A Postgres specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of Postgres. =head1 METHODS =cut =head2 Connect Connect takes a hashref and passes it off to SUPER::Connect; Forces the timezone to GMT it returns a database handle. =cut sub Connect { my $self = shift; my $rv = $self->SUPER::Connect(@_); $self->SimpleQuery("SET TIME ZONE 'GMT'"); $self->SimpleQuery("SET DATESTYLE TO 'ISO'"); $self->AutoCommit(1); return ($rv); } =head2 BuildDSN Extend L to force C to be UTF-8, so that character strings can be safely passed to, and retrieved from, the database. See L. =cut sub BuildDSN { my $self = shift; $self->SUPER::BuildDSN(@_); $self->{'dsn'} .= ';client_encoding=UTF8'; return $self->{'dsn'}; } =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. In case of insert failure, returns a L object preloaded with error info. =cut sub Insert { my $self = shift; my $table = shift; my %args = (@_); my $sth = $self->SUPER::Insert( $table, %args ); return $sth unless $sth; if ( $args{'id'} || $args{'Id'} ) { $self->{'id'} = $args{'id'} || $args{'Id'}; return ( $self->{'id'} ); } my $sequence_name = $self->IdSequenceName($table); unless ($sequence_name) { return ($sequence_name) } # Class::ReturnValue my $seqsth = $self->dbh->prepare( qq{SELECT CURRVAL('} . $sequence_name . qq{')} ); $seqsth->execute; $self->{'id'} = $seqsth->fetchrow_array(); return ( $self->{'id'} ); } =head2 InsertQueryString Postgres sepcific overriding method for L. =cut sub InsertQueryString { my $self = shift; my ($query_string, @bind) = $self->SUPER::InsertQueryString( @_ ); $query_string =~ s/\(\s*\)\s+VALUES\s+\(\s*\)\s*$/DEFAULT VALUES/; return ($query_string, @bind); } =head2 IdSequenceName TABLE Takes a TABLE name and returns the name of the sequence of the primary key for that table. =cut sub IdSequenceName { my $self = shift; my $table = shift; return $self->{'_sequences'}{$table} if (exists $self->{'_sequences'}{$table}); # Let's get the id of that row we just inserted my $seq; my $colinfosth = $self->dbh->column_info( undef, undef, lc($table), '%' ); while ( my $foo = $colinfosth->fetchrow_hashref ) { # Regexp from DBIx::Class's Pg handle. Thanks to Marcus Ramberg if ( defined $foo->{'COLUMN_DEF'} && $foo->{'COLUMN_DEF'} =~ m!^nextval\(+'"?([^"']+)"?'(::(?:text|regclass)\))+!i ) { return $self->{'_sequences'}{$table} = $1; } } my $ret = Class::ReturnValue->new(); $ret->as_error( errno => '-1', message => "Found no sequence for $table", do_backtrace => undef ); return ( $ret->return_value ); } =head2 BinarySafeBLOBs Return undef, as no current version of postgres supports binary-safe blobs =cut sub BinarySafeBLOBs { my $self = shift; return(undef); } =head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE starting with FIRST_ROW; =cut sub ApplyLimits { my $self = shift; my $statementref = shift; my $per_page = shift; my $first = shift; my $limit_clause = ''; if ( $per_page) { $limit_clause = " LIMIT "; $limit_clause .= $per_page; if ( $first && $first != 0 ) { $limit_clause .= " OFFSET $first"; } } $$statementref .= $limit_clause; } =head2 _MakeClauseCaseInsensitive FIELD OPERATOR VALUE Takes a field, operator and value. performs the magic necessary to make your database treat this clause as case insensitive. Returns a FIELD OPERATOR VALUE triple. =cut sub _MakeClauseCaseInsensitive { my $self = shift; my $field = shift; my $operator = shift; my $value = shift; # we don't need to downcase numeric values and dates if ($value =~ /^$DBIx::SearchBuilder::Handle::RE_CASE_INSENSITIVE_CHARS+$/o) { return ( $field, $operator, $value); } if ( $operator =~ /LIKE/i ) { $operator =~ s/LIKE/ILIKE/ig; return ( $field, $operator, $value ); } elsif ( $operator =~ /=/ ) { 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 # on the value. they only expect field, operator, value. # else { return ( "LOWER($field)", $operator, lc($value)); } } else { $self->SUPER::_MakeClauseCaseInsensitive( $field, $operator, $value ); } } =head2 DistinctQuery STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; my $table = $sb->Table; return $self->SUPER::DistinctQuery( $statementref, $sb, @_ ) if $sb->_OrderClause !~ /(?DatabaseVersion =~ /^(\d+)\.(\d+)/ and ($1 > 9 or ($1 == 9 and $2 >= 1))) { # Pg 9.1 supports "SELECT main.foo ... GROUP BY main.id" if id is the primary key $groups = [ {FIELD => "id"} ]; } else { # For earlier versions, we have to list out all of the columns $groups = [ map {+{FIELD => $_}} $self->Fields($table) ]; } local $sb->{group_by} = $groups; local $sb->{'order_by'} = [ map { ($_->{'ALIAS'}||'') ne "main" ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" } : $_ } @{$sb->{'order_by'}} ]; my $group = $sb->_GroupClause; my $order = $sb->_OrderClause; $$statementref = "SELECT main.* FROM $$statementref $group $order"; } =head2 SimpleDateTimeFunctions Returns hash reference with specific date time functions of this database for L. =cut sub SimpleDateTimeFunctions { my $self = shift; return $self->{'_simple_date_time_functions'} if $self->{'_simple_date_time_functions'}; my %res = %{ $self->SUPER::SimpleDateTimeFunctions(@_) }; s/SUBSTR\s*\(\s*\?/SUBSTR( CAST(? AS text)/ig for values %res; # everything else we should implement through date_trunc that # does SUBSTR(?, 1, X) on a date, but leaves trailing values # when we don't need them return $self->{'_simple_date_time_functions'} ||= { %res, datetime => '?', time => 'CAST(? AS time)', hour => 'EXTRACT(HOUR FROM ?)', date => 'CAST(? AS date)', daily => 'CAST(? AS date)', day => 'EXTRACT(DAY FROM ?)', month => 'EXTRACT(MONTH FROM ?)', annually => 'EXTRACT(YEAR FROM ?)', year => 'EXTRACT(YEAR FROM ?)', dayofweek => "EXTRACT(DOW FROM ?)", # 0-6, 0 - Sunday dayofyear => "EXTRACT(DOY FROM ?)", # 1-366 # 1-53, 1st week January 4, week starts on Monay weekofyear => "EXTRACT(WEEK FROM ?)", }; } =head2 ConvertTimezoneFunction Custom implementation of L. In Pg time and timestamp data types may be "with time zone" or "without time zone". So if Field argument is timestamp "with time zone" then From argument is not required and is useless. Otherwise From argument identifies time zone of the Field argument that is "without time zone". For consistency with other DBs use timestamp columns without time zones and provide From argument. =cut sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'} unless $args{From} && $args{'To'}; return $args{'Field'} if lc $args{From} eq lc $args{'To'}; my $dbh = $self->dbh; my $res = $args{'Field'}; $res = "TIMEZONE($_, $res)" foreach map $dbh->quote( $_ ), grep $_, @args{'From', 'To'}; return $res; } sub _DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); return "(EXTRACT(EPOCH FROM $args{'To'}) - EXTRACT(EPOCH FROM $args{'From'}))"; } sub HasSupportForNullsOrder { return 1; } 1; __END__ =head1 SEE ALSO DBIx::SearchBuilder, DBIx::SearchBuilder::Handle =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Handle/Sybase.pm000644 000765 000024 00000005752 13275205765 024664 0ustar00sunnavystaff000000 000000 # $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/Sybase.pm,v 1.8 2001/10/12 05:27:05 jesse Exp $ package DBIx::SearchBuilder::Handle::Sybase; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::Sybase -- a Sybase specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of Sybase. =head1 METHODS =cut =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. If the insert succeeds, returns the id of the insert, otherwise, returns a Class::ReturnValue object with the error reported. =cut sub Insert { my $self = shift; my $table = shift; my %pairs = @_; my $sth = $self->SUPER::Insert( $table, %pairs ); if ( !$sth ) { return ($sth); } # Can't select identity column if we're inserting the id by hand. unless ($pairs{'id'}) { my @row = $self->FetchResult('SELECT @@identity'); # TODO: Propagate Class::ReturnValue up here. unless ( $row[0] ) { return (undef); } $self->{'id'} = $row[0]; } return ( $self->{'id'} ); } =head2 DatabaseVersion return the database version, trimming off any -foo identifier =cut sub DatabaseVersion { my $self = shift; my $v = $self->SUPER::DatabaseVersion(); $v =~ s/\-(.*)$//; return ($v); } =head2 CaseSensitive Returns undef, since Sybase's searches are not case sensitive by default =cut sub CaseSensitive { my $self = shift; return(1); } sub ApplyLimits { my $self = shift; my $statementref = shift; my $per_page = shift; my $first = shift; } =head2 DistinctQuery STATEMENTREFtakes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; my $table = $sb->Table; if ($sb->_OrderClause =~ /(?_GroupClause; $$statementref .= $sb->_OrderClause; } =head2 BinarySafeBLOBs Return undef, as Oracle doesn't support binary-safe CLOBS =cut sub BinarySafeBLOBs { my $self = shift; return(undef); } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO DBIx::SearchBuilder, DBIx::SearchBuilder::Handle =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Handle/SQLite.pm000644 000765 000024 00000012515 14113013573 024554 0ustar00sunnavystaff000000 000000 package DBIx::SearchBuilder::Handle::SQLite; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::SQLite -- A SQLite specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of SQLite. =head1 METHODS =head2 DatabaseVersion Returns the version of the SQLite library which is used, e.g., "2.8.0". SQLite can only return short variant. =cut sub DatabaseVersion { my $self = shift; return '' unless $self->dbh; return $self->dbh->{sqlite_version} || ''; } =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. If the insert succeeds, returns the id of the insert, otherwise, returns a Class::ReturnValue object with the error reported. =cut sub _last_insert_rowid { my $self = shift; my $table = shift; return $self->dbh->func('last_insert_rowid'); # XXX: this is workaround nesty sqlite problem that # last_insert_rowid in transaction is inaccurrate with multiple # inserts. return $self->dbh->func('last_insert_rowid') unless $self->TransactionDepth; # XXX: is the name of the column always id ? my $ret = $self->FetchResult("select max(id) from $table"); return $ret; } sub Insert { my $self = shift; my $table = shift; my %args = ( id => undef, @_); # We really don't want an empty id my $sth = $self->SUPER::Insert($table, %args); return unless $sth; # If we have set an id, then we want to use that, otherwise, we want to lookup the last _new_ rowid $self->{'id'}= $args{'id'} || $self->_last_insert_rowid($table); warn "$self no row id returned on row creation" unless ($self->{'id'}); return( $self->{'id'}); #Add Succeded. return the id } =head2 CaseSensitive Returns undef, since SQLite's searches are not case sensitive by default =cut sub CaseSensitive { my $self = shift; return(1); } sub BinarySafeBLOBs { return undef; } sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; return $self->SUPER::DistinctQuery( $statementref, $sb, @_ ) if $sb->_OrderClause !~ /(?{'group_by'} = [{FIELD => 'id'}]; local $sb->{'order_by'} = [ map { ($_->{'ALIAS'}||'') ne "main" ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" } : $_ } @{$sb->{'order_by'}} ]; $$statementref = "SELECT main.* FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } =head2 DistinctCount STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result count =cut sub DistinctCount { my $self = shift; my $statementref = shift; my $sb = shift; $$statementref = "SELECT count(*) FROM (SELECT DISTINCT main.id FROM $$statementref )"; } sub Fields { my $self = shift; my $table = shift; my $cache = \%DBIx::SearchBuilder::Handle::FIELDS_IN_TABLE; unless ( $cache->{lc $table} ) { my $info = $self->dbh->selectall_arrayref("PRAGMA table_info('$table')") or return (); foreach my $e ( @$info ) { push @{ $cache->{ lc $table } ||= [] }, lc $e->[1]; } } return @{ $cache->{ lc $table } || [] }; } =head2 SimpleDateTimeFunctions Returns hash reference with specific date time functions of this database for L. =cut sub SimpleDateTimeFunctions { my $self = shift; return $self->{'_simple_date_time_functions'} ||= { %{ $self->SUPER::SimpleDateTimeFunctions(@_) }, datetime => 'datetime(?)', time => 'time(?)', hourly => "strftime('%Y-%m-%d %H', ?)", hour => "strftime('%H', ?)", date => 'date(?)', daily => 'date(?)', day => "strftime('%d', ?)", dayofmonth => "strftime('%d', ?)", monthly => "strftime('%Y-%m', ?)", month => "strftime('%m', ?)", annually => "strftime('%Y', ?)", year => "strftime('%Y', ?)", dayofweek => "strftime('%w', ?)", dayofyear => "strftime('%j', ?)", weekofyear => "strftime('%W', ?)", }; } sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'} unless $args{From} && $args{'To'}; return $args{'Field'} if lc $args{From} eq lc $args{'To'}; my $res; if ( lc($args{'To'}||'') eq 'utc' ) { $res = "datetime($args{'Field'}, 'utc')"; } elsif ( lc($args{'From'}||'') eq 'utc' ) { $res = "datetime($args{'Field'}, 'localtime')"; } else { warn "SQLite only supports TZ convesion from UTC or to UTC"; $res = $args{'Field'}; } return $res; } sub _DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); return "strftime('%s',$args{'To'}) - strftime('%s',$args{'From'})"; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO perl(1), DBIx::SearchBuilder =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Handle/Informix.pm000644 000765 000024 00000006316 13275205765 025226 0ustar00sunnavystaff000000 000000 # $Header: $ package DBIx::SearchBuilder::Handle::Informix; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::Informix - An Informix specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of Informix. =head1 METHODS =cut =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. If the insert succeeds, returns the id of the insert, otherwise, returns a Class::ReturnValue object with the error reported. =cut sub Insert { my $self = shift; my $sth = $self->SUPER::Insert(@_); if (!$sth) { print "no sth! (".$self->dbh->{ix_sqlerrd}[1].")\n"; return ($sth); } $self->{id}=$self->dbh->{ix_sqlerrd}[1]; warn "$self no row id returned on row creation" unless ($self->{'id'}); return( $self->{'id'}); #Add Succeded. return the id } =head2 CaseSensitive Returns 1, since Informix's searches are case sensitive by default =cut sub CaseSensitive { my $self = shift; return(1); } =head2 BuildDSN Builder for Informix DSNs. =cut sub BuildDSN { my $self = shift; my %args = ( Driver => undef, Database => undef, Host => undef, Port => undef, SID => undef, RequireSSL => undef, @_); my $dsn = "dbi:$args{'Driver'}:"; $dsn .= "$args{'Database'}" if (defined $args{'Database'} && $args{'Database'}); $self->{'dsn'}= $dsn; } =head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE starting with FIRST_ROW; =cut sub ApplyLimits { my $self = shift; my $statementref = shift; my $per_page = shift; my $first = shift; # XXX TODO THIS only works on the FIRST page of results. that's a bug if ($per_page) { $$statementref =~ s[^\s*SELECT][SELECT FIRST $per_page]i; } } sub Disconnect { my $self = shift; if ($self->dbh) { my $status = $self->dbh->disconnect(); $self->dbh( undef); return $status; } else { return; } } =head2 DistinctQuery STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; my $table = $sb->Table; if ($sb->_OrderClause =~ /(?_GroupClause; $$statementref .= $sb->_OrderClause; } 1; __END__ =head1 AUTHOR Oliver Tappe, oliver@akso.de =head1 SEE ALSO perl(1), DBIx::SearchBuilder =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Handle/Oracle.pm000755 000765 000024 00000027213 13624054424 024632 0ustar00sunnavystaff000000 000000 # $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/Oracle.pm,v 1.14 2002/01/28 06:11:37 jesse Exp $ package DBIx::SearchBuilder::Handle::Oracle; use strict; use warnings; use base qw/DBIx::SearchBuilder::Handle/; use DBD::Oracle qw(:ora_types ORA_OCI); =head1 NAME DBIx::SearchBuilder::Handle::Oracle - An oracle specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of Oracle. =head1 METHODS =cut =head2 Connect PARAMHASH: Driver, Database, Host, User, Password Takes a paramhash and connects to your DBI datasource. =cut sub Connect { my $self = shift; my %args = ( Driver => undef, Database => undef, User => undef, Password => undef, SID => undef, Host => undef, @_); my $rv = $self->SUPER::Connect(%args); $self->dbh->{LongTruncOk}=1; $self->dbh->{LongReadLen}=8000; foreach my $setting (qw(DATE TIMESTAMP TIMESTAMP_TZ)) { $self->SimpleQuery( "ALTER SESSION set NLS_${setting}_FORMAT = 'YYYY-MM-DD HH24:MI:SS'" ); } return ($rv); } =head2 BuildDSN Customized version of L method. Takes additional argument SID. Database argument used unless SID provided. Two forms of DSN are generated depending on whether Host defined or not: dbi:Oracle:sid=;host=...[;port=...] dbi:Oracle: Read details in documentation for L module. =cut sub BuildDSN { my $self = shift; my %args = ( Driver => undef, Database => undef, Host => undef, Port => undef, SID => undef, @_ ); $args{'Driver'} ||= 'Oracle'; # read DBD::Oracle for details, but basicly it supports # either 'dbi:Oracle:SID' or 'dbi:Oracle:sid=SID;host=...;[port=...;]' # and tests shows that 'dbi:Oracle:SID' != 'dbi:Oracle:sid=SID' $args{'SID'} ||= $args{'Database'}; my $dsn = "dbi:$args{'Driver'}:"; if ( $args{'Host'} ) { $dsn .= "sid=$args{'SID'}" if $args{'SID'}; $dsn .= ";host=$args{'Host'}"; $dsn .= ";port=$args{'Port'}" if $args{'Port'}; } else { $dsn .= $args{'SID'} if $args{'SID'}; $dsn .= ";port=$args{'Port'}" if $args{'Port'}; } return $self->{'dsn'} = $dsn; } =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. =cut sub Insert { my $self = shift; my $table = shift; my ($sth); # Oracle Hack to replace non-supported mysql_rowid call my %attribs = @_; my ($unique_id, $QueryString); if ($attribs{'Id'} || $attribs{'id'}) { $unique_id = ($attribs{'Id'} ? $attribs{'Id'} : $attribs{'id'} ); } else { $QueryString = "SELECT ".$table."_seq.nextval FROM DUAL"; $sth = $self->SimpleQuery($QueryString); if (!$sth) { if ($main::debug) { die "Error with $QueryString"; } else { return (undef); } } #needs error checking my @row = $sth->fetchrow_array; $unique_id = $row[0]; } #TODO: don't hardcode this to id pull it from somewhere else #call super::Insert with the new column id. $attribs{'id'} = $unique_id; delete $attribs{'Id'}; $sth = $self->SUPER::Insert( $table, %attribs); unless ($sth) { if ($main::debug) { die "Error with $QueryString: ". $self->dbh->errstr; } else { return (undef); } } $self->{'id'} = $unique_id; return( $self->{'id'}); #Add Succeded. return the id } =head2 InsertFromSelect Customization of L. Unlike other DBs Oracle needs: =over 4 =item * id generated from sequences for every new record. =item * query wrapping in parens. =back B that on Oracle there is a limitation on the query. Every column in the result should have unique name or alias, for example the following query would generate "ORA-00918: column ambiguously defined" error: SELECT g.id, u.id FROM ... Solve with aliases: SELECT g.id AS group_id, u.id AS user_id FROM ... =cut sub InsertFromSelect { my ($self, $table, $columns, $query, @binds) = @_; if ( $columns && !grep lc($_) eq 'id', @$columns ) { unshift @$columns, 'id'; $query = "SELECT ${table}_seq.nextval, insert_from.* FROM ($query) insert_from"; } return $self->SUPER::InsertFromSelect( $table, $columns, "($query)", @binds); } =head2 KnowsBLOBs Returns 1 if the current database supports inserts of BLOBs automatically. Returns undef if the current database must be informed of BLOBs for inserts. =cut sub KnowsBLOBs { my $self = shift; return(undef); } =head2 BLOBParams FIELD_NAME FIELD_TYPE Returns a hash ref for the bind_param call to identify BLOB types used by the current database for a particular column type. The current Oracle implementation only supports ORA_CLOB types (112). =cut sub BLOBParams { my $self = shift; my $field = shift; #my $type = shift; # Don't assign to key 'value' as it is defined later. return ( { ora_field => $field, ora_type => ORA_CLOB, }); } =head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE starting with FIRST_ROW; =cut sub ApplyLimits { my $self = shift; my $statementref = shift; my $per_page = shift; my $first = shift; # Transform an SQL query from: # # SELECT main.* # FROM Tickets main # WHERE ((main.EffectiveId = main.id)) # AND ((main.Type = 'ticket')) # AND ( ( (main.Status = 'new')OR(main.Status = 'open') ) # AND ( (main.Queue = '1') ) ) # # to: # # SELECT * FROM ( # SELECT limitquery.*,rownum limitrownum FROM ( # SELECT main.* # FROM Tickets main # WHERE ((main.EffectiveId = main.id)) # AND ((main.Type = 'ticket')) # AND ( ( (main.Status = 'new')OR(main.Status = 'open') ) # AND ( (main.Queue = '1') ) ) # ) limitquery WHERE rownum <= 50 # ) WHERE limitrownum >= 1 # if ($per_page) { # Oracle orders from 1 not zero $first++; # Make current query a sub select $$statementref = "SELECT * FROM ( SELECT limitquery.*,rownum limitrownum FROM ( $$statementref ) limitquery WHERE rownum <= " . ($first + $per_page - 1) . " ) WHERE limitrownum >= " . $first; } } =head2 DistinctQuery STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; my $table = $sb->Table; my $hint = $sb->QueryHint; $hint = $hint ? " /* $hint */ " : " "; if ($sb->_OrderClause =~ /(?{group_by} = [@{$sb->{group_by} || []}, {FIELD => 'id'}]; local $sb->{'order_by'} = [ map { ($_->{'ALIAS'}||'') ne "main" ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" } : $_ } @{$sb->{'order_by'}} ]; my $group = $sb->_GroupClause; my $order = $sb->_OrderClause; $$statementref = "SELECT" . $hint . "main.* FROM ( SELECT main.id, row_number() over( $order ) sortorder FROM $$statementref $group ) distinctquery, $table main WHERE (main.id = distinctquery.id) ORDER BY distinctquery.sortorder"; } else { # Wrapp select query in a subselect as Oracle doesn't allow # DISTINCT against CLOB/BLOB column types. $$statementref = "SELECT" . $hint . " main.* FROM ( SELECT DISTINCT main.id FROM $$statementref ) distinctquery, $table main WHERE (main.id = distinctquery.id) "; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } } =head2 BinarySafeBLOBs Return undef, as Oracle doesn't support binary-safe CLOBS =cut sub BinarySafeBLOBs { my $self = shift; return(undef); } =head2 DatabaseVersion Returns value of ORA_OCI constant, see L. =cut sub DatabaseVersion { return ''. ORA_OCI; } sub Fields { my $self = shift; my $table = shift; my $cache = \%DBIx::SearchBuilder::Handle::FIELDS_IN_TABLE; unless ( $cache->{ lc $table } ) { # uc(table) required as oracle stores UC names in information tables # and lookup clauses are case sensetive my $sth = $self->dbh->column_info( undef, undef, uc($table), '%' ) or return (); my $info = $sth->fetchall_arrayref({}); # TODO: not sure why results are lower case, probably NAME_ls affects it # we should check it out at some point foreach my $e ( sort {$a->{'ordinal_position'} <=> $b->{'ordinal_position'}} @$info ) { push @{ $cache->{ lc $e->{'table_name'} } ||= [] }, lc $e->{'column_name'}; } } return @{ $cache->{ lc $table } || [] }; } =head2 SimpleDateTimeFunctions Returns hash reference with specific date time functions of this database for L. =cut # http://download.oracle.com/docs/cd/B14117_01/server.101/b10749/ch4datetime.htm sub SimpleDateTimeFunctions { my $self = shift; return $self->{'_simple_date_time_functions'} if $self->{'_simple_date_time_functions'}; my %res = %{ $self->SUPER::SimpleDateTimeFunctions(@_) }; return $self->{'_simple_date_time_functions'} ||= { %res, datetime => "?", time => "TO_CHAR(?, 'HH24:MI:SS')", hourly => "TO_CHAR(?, 'YYYY-MM-DD HH24')", hour => "TO_CHAR(?, 'HH24')", date => "TO_CHAR(?, 'YYYY-MM-DD')", daily => "TO_CHAR(?, 'YYYY-MM-DD')", day => "TO_CHAR(?, 'DD')", dayofmonth => "TO_CHAR(?, 'DD')", monthly => "TO_CHAR(?, 'YYYY-MM')", month => "TO_CHAR(?, 'MM')", annually => "TO_CHAR(?, 'YYYY')", year => "TO_CHAR(?, 'YYYY')", dayofweek => "TO_CHAR(?, 'D') - 1", # 1-7, 1 - Sunday dayofyear => "TO_CHAR(?, 'DDD')", # 1-366 # no idea about props weekofyear => "TO_CHAR(?, 'WW')", }; } =head2 ConvertTimezoneFunction Custom implementation of L. Use the following query to get list of timezones: SELECT tzname FROM v$timezone_names; Read Oracle's docs about timezone files: http://download.oracle.com/docs/cd/B14117_01/server.101/b10749/ch4datetime.htm#i1006667 =cut sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'} unless $args{From} && $args{'To'}; return $args{'Field'} if lc $args{From} eq lc $args{'To'}; my $dbh = $self->dbh; $_ = $dbh->quote( $_ ) foreach @args{'From', 'To'}; return "FROM_TZ( CAST ($args{'Field'} AS TIMESTAMP), $args{'From'}) AT TIME ZONE $args{'To'}"; } sub _DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); return "ROUND(( CAST( $args{'To'} AS DATE ) - CAST( $args{'From'} AS DATE ) ) * 86400)"; } sub HasSupportForNullsOrder { return 1; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO perl(1), DBIx::SearchBuilder =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Handle/mysql.pm000755 000765 000024 00000022523 14123427067 024573 0ustar00sunnavystaff000000 000000 # $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/mysql.pm,v 1.8 2001/10/12 05:27:05 jesse Exp $ package DBIx::SearchBuilder::Handle::mysql; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::mysql - A mysql specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of MySQL. =head1 METHODS =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. If the insert succeeds, returns the id of the insert, otherwise, returns a Class::ReturnValue object with the error reported. =cut sub Insert { my $self = shift; my $sth = $self->SUPER::Insert(@_); if (!$sth) { return ($sth); } $self->{'id'}=$self->dbh->{'mysql_insertid'}; # Yay. we get to work around mysql_insertid being null some of the time :/ unless ($self->{'id'}) { $self->{'id'} = $self->FetchResult('SELECT LAST_INSERT_ID()'); } warn "$self no row id returned on row creation" unless ($self->{'id'}); return( $self->{'id'}); #Add Succeded. return the id } =head2 SimpleUpdateFromSelect Customization of L. Mysql doesn't support update with subqueries when those fetch data from the table that is updated. =cut sub SimpleUpdateFromSelect { my ($self, $table, $values, $query, @query_binds) = @_; return $self->SUPER::SimpleUpdateFromSelect( $table, $values, $query, @query_binds ) unless $query =~ /\b\Q$table\E\b/i; my $sth = $self->SimpleQuery( $query, @query_binds ); return $sth unless $sth; my (@binds, @columns); for my $k (sort keys %$values) { push @columns, $k; push @binds, $values->{$k}; } $table = $self->QuoteName($table) if $self->{'QuoteTableNames'}; my $update_query = "UPDATE $table SET " . join( ', ', map "$_ = ?", @columns ) .' WHERE ID IN '; return $self->SimpleMassChangeFromSelect( $update_query, \@binds, $query, @query_binds ); } sub DeleteFromSelect { my ($self, $table, $query, @query_binds) = @_; return $self->SUPER::DeleteFromSelect( $table, $query, @query_binds ) unless $query =~ /\b\Q$table\E\b/i; $table = $self->QuoteName($table) if $self->{'QuoteTableNames'}; return $self->SimpleMassChangeFromSelect( "DELETE FROM $table WHERE id IN ", [], $query, @query_binds ); } sub SimpleMassChangeFromSelect { my ($self, $update_query, $update_binds, $search, @search_binds) = @_; my $sth = $self->SimpleQuery( $search, @search_binds ); return $sth unless $sth; # tried TEMPORARY tables, much slower than fetching and delete # also size of ENGINE=MEMORY is limitted by option, on disk # tables more slower than in memory my $res = 0; my @ids; while ( my $id = ($sth->fetchrow_array)[0] ) { push @ids, $id; next if @ids < 1000; my $q = $update_query .'('. join( ',', ('?')x@ids ) .')'; my $sth = $self->SimpleQuery( $q, @$update_binds, splice @ids ); return $sth unless $sth; $res += $sth->rows; } if ( @ids ) { my $q = $update_query .'('. join( ',', ('?')x@ids ) .')'; my $sth = $self->SimpleQuery( $q, @$update_binds, splice @ids ); return $sth unless $sth; $res += $sth->rows; } return $res == 0? '0E0': $res; } =head2 DatabaseVersion Returns the mysql version, trimming off any -foo identifier =cut sub DatabaseVersion { my $self = shift; my $v = $self->SUPER::DatabaseVersion(); $v =~ s/\-.*$//; return ($v); } =head2 CaseSensitive Returns undef, since mysql's searches are not case sensitive by default =cut sub CaseSensitive { my $self = shift; return(undef); } sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; return $self->SUPER::DistinctQuery( $statementref, $sb, @_ ) if $sb->_OrderClause !~ /(?DatabaseVersion, 0, 1) == 4 ) { local $sb->{'group_by'} = [{FIELD => 'id'}]; my ($idx, @tmp, @specials) = (0, ()); foreach ( @{$sb->{'order_by'}} ) { if ( !exists $_->{'ALIAS'} || ($_->{'ALIAS'}||'') eq "main" ) { push @tmp, $_; next; } push @specials, ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(". $_->{'ALIAS'} .".". $_->{'FIELD'} .")" ." __special_sort_$idx"; push @tmp, { ALIAS => '', FIELD => "__special_sort_$idx", ORDER => $_->{'ORDER'} }; $idx++; } local $sb->{'order_by'} = \@tmp; $$statementref = "SELECT ". join( ", ", 'main.*', @specials ) ." FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } else { local $sb->{'group_by'} = [{FIELD => 'id'}]; local $sb->{'order_by'} = [ map { ($_->{'ALIAS'}||'') ne "main" ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" } : $_ } @{$sb->{'order_by'}} ]; $$statementref = "SELECT main.* FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } } sub Fields { my $self = shift; my $table = shift; my $cache = \%DBIx::SearchBuilder::Handle::FIELDS_IN_TABLE; unless ( $cache->{ lc $table } ) { my $sth = $self->dbh->column_info( undef, undef, $table, '%' ) or return (); my $info = $sth->fetchall_arrayref({}); foreach my $e ( sort {$a->{'ORDINAL_POSITION'} <=> $b->{'ORDINAL_POSITION'}} @$info ) { push @{ $cache->{ lc $e->{'TABLE_NAME'} } ||= [] }, lc $e->{'COLUMN_NAME'}; } } return @{ $cache->{ lc $table } || [] }; } =head2 SimpleDateTimeFunctions Returns hash reference with specific date time functions of this database for L. =cut sub SimpleDateTimeFunctions { my $self = shift; return $self->{'_simple_date_time_functions'} ||= { %{ $self->SUPER::SimpleDateTimeFunctions(@_) }, datetime => '?', time => 'TIME(?)', hourly => "DATE_FORMAT(?, '%Y-%m-%d %H')", hour => 'HOUR(?)', date => 'DATE(?)', daily => 'DATE(?)', day => 'DAYOFMONTH(?)', dayofmonth => 'DAYOFMONTH(?)', monthly => "DATE_FORMAT(?, '%Y-%m')", month => 'MONTH(?)', annually => 'YEAR(?)', year => 'YEAR(?)', dayofweek => "DAYOFWEEK(?) - 1", # 1-7, 1 - Sunday dayofyear => "DAYOFYEAR(?)", # 1-366 weekofyear => "WEEK(?)", # skip mode argument, so it can be controlled in mysql config }; } =head2 ConvertTimezoneFunction Custom implementation of L. Use the following query to get list of timezones: SELECT Name FROM mysql.time_zone_name; Read docs about keeping timezone data up to date: http://dev.mysql.com/doc/refman/5.5/en/time-zone-upgrades.html =cut sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'} unless $args{From} && $args{'To'}; return $args{'Field'} if lc $args{From} eq lc $args{'To'}; my $dbh = $self->dbh; $_ = $dbh->quote( $_ ) foreach @args{'From', 'To'}; return "CONVERT_TZ( $args{'Field'}, $args{'From'}, $args{'To'} )"; } sub _DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); return "TIMESTAMPDIFF(SECOND, $args{'From'}, $args{'To'})"; } =head2 QuoteName Quote table or column name to avoid reserved word errors. =cut # over-rides inherited method sub QuoteName { my ($self, $name) = @_; # use dbi built in quoting if we have a connection, if ($self->dbh) { return $self->SUPER::QuoteName($name); } return sprintf('`%s`', $name); } sub DequoteName { my ($self, $name) = @_; # If we have a handle, the base class can do it for us if ($self->dbh) { return $self->SUPER::DequoteName($name); } if ($name =~ /^`(.*)`$/) { return $1; } return $name; } sub _ExtractBindValues { my $self = shift; my $value = shift; return $self->SUPER::_ExtractBindValues( $value, '\\' ); } sub _IsMariaDB { my $self = shift; # We override DatabaseVersion to chop off "-MariaDB-whatever", so # call super here to get the original version my $v = $self->SUPER::DatabaseVersion(); return ($v =~ /mariadb/i); } sub _RequireQuotedTables { my $self = shift; # MariaDB version does not match mysql, and hasn't added new reserved words return 0 if $self->_IsMariaDB; my $version = $self->DatabaseVersion; # Get major version number by chopping off everything after the first "." $version =~ s/\..*//; if ( $version >= 8 ) { return 1; } return 0; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO DBIx::SearchBuilder, DBIx::SearchBuilder::Handle =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Handle/mysqlPP.pm000644 000765 000024 00000000711 13275205765 025031 0ustar00sunnavystaff000000 000000 package DBIx::SearchBuilder::Handle::mysqlPP; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle::mysql); 1; __END__ =head1 NAME DBIx::SearchBuilder::Handle::mysqlPP - A mysql specific Handle object =head1 DESCRIPTION A Handle subclass for the "pure perl" mysql database driver. This is currently identical to the DBIx::SearchBuilder::Handle::mysql class. =head1 AUTHOR =head1 SEE ALSO DBIx::SearchBuilder::Handle::mysql =cut DBIx-SearchBuilder-1.71/lib/DBIx/SearchBuilder/Record/Cachable.pm000755 000765 000024 00000016040 13712600174 025123 0ustar00sunnavystaff000000 000000 # $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Record/Cachable.pm,v 1.6 2001/06/19 04:22:32 jesse Exp $ # by Matt Knopp package DBIx::SearchBuilder::Record::Cachable; use strict; use warnings; use DBIx::SearchBuilder::Handle; use Cache::Simple::TimedExpiry; use base qw(DBIx::SearchBuilder::Record); =head1 NAME DBIx::SearchBuilder::Record::Cachable - Records with caching behavior =head1 SYNOPSIS package MyRecord; use base qw/DBIx::SearchBuilder::Record::Cachable/; =head1 DESCRIPTION This module subclasses the main L package to add a caching layer. The public interface remains the same, except that records which have been loaded in the last few seconds may be reused by subsequent fetch or load methods without retrieving them from the database. =head1 METHODS =cut my %_CACHES = (); sub _SetupCache { my ($self, $cache) = @_; $_CACHES{$cache} = Cache::Simple::TimedExpiry->new(); $_CACHES{$cache}->expire_after( $self->_CacheConfig->{'cache_for_sec'} ); return $_CACHES{$cache}; } =head2 FlushCache This class method flushes the _global_ DBIx::SearchBuilder::Record::Cachable cache. All caches are immediately expired. =cut sub FlushCache { %_CACHES = (); } =head2 _FlushKeyCache Blow away this record type's key cache =cut sub _FlushKeyCache { my $self = shift; my $cache = ($self->{_class}||= ref($self))."-KEYS"; return $self->_SetupCache($cache); } sub _KeyCache { my $self = shift; my $cache = ($self->{_class}||= ref($self))."-KEYS"; return $_CACHES{$cache} || $self->_SetupCache($cache); } sub _RecordCache { my $self = shift; my $cache = ($self->{_class}||= ref($self)); return $_CACHES{$cache} || $self->_SetupCache($cache); } # Function: LoadFromHash # Type : (overloaded) public instance # Args : See DBIx::SearchBuilder::Record::LoadFromHash # Lvalue : array(boolean, message) sub LoadFromHash { my $self = shift; # Blow away the primary cache key since we're loading. $self->{'_SB_Record_Primary_RecordCache_key'} = undef; my ( $rvalue, $msg ) = $self->SUPER::LoadFromHash(@_); ## Check the return value, if its good, cache it! $self->_store if $rvalue; return ( $rvalue, $msg ); } # Function: LoadByCols # Type : (overloaded) public instance # Args : see DBIx::SearchBuilder::Record::LoadByCols # Lvalue : array(boolean, message) sub LoadByCols { my ( $self, %attr ) = @_; # Blow away the primary cache key since we're loading. $self->{'_SB_Record_Primary_RecordCache_key'} = undef; # generate the alternate cache key my $alt_key = $self->_gen_alternate_RecordCache_key(%attr); # get primary cache key my $cache_key = $self->_lookup_primary_RecordCache_key($alt_key); if ( $cache_key && $self->_fetch( $cache_key ) ) { return ( 1, "Fetched from cache" ); } # Fetch from the DB! my ( $rvalue, $msg ) = $self->SUPER::LoadByCols(%attr); # Check the return value, if its good, cache it! if ($rvalue) { $self->_store(); # store alt_key as alias for pk $self->_KeyCache->set( $alt_key, $self->_primary_RecordCache_key); } return ( $rvalue, $msg ); } # Function: __Set # Type : (overloaded) public instance # Args : see DBIx::SearchBuilder::Record::_Set # Lvalue : ? sub __Set () { my $self = shift; $self->_expire; return $self->SUPER::__Set( @_ ); } # Function: Delete # Type : (overloaded) public instance # Args : nil # Lvalue : ? sub __Delete () { my $self = shift; $self->_expire; return $self->SUPER::__Delete( @_ ); } # Function: _expire # Type : private instance # Args : string(cache_key) # Lvalue : 1 # Desc : Removes this object from the cache. sub _expire (\$) { my $self = shift; my $cache_key = $self->_primary_RecordCache_key or return; $self->_RecordCache->set( $cache_key, undef, time-1 ); # We should be doing something more surgical to clean out the # key cache. but we do need to expire it $self->_FlushKeyCache; } # Function: _fetch # Type : private instance # Args : string(cache_key) # Lvalue : 1 # Desc : Get an object from the cache, and make this object that. sub _fetch () { my ( $self, $cache_key ) = @_; my $data = $self->_RecordCache->fetch( $cache_key ) or return 0; @{$self}{keys %$data} = values %$data; # deserialize return 1; } # Function: _store # Type : private instance # Args : string(cache_key) # Lvalue : 1 # Desc : Stores this object in the cache. sub _store (\$) { my $self = shift; my $key = $self->_primary_RecordCache_key or return 0; $self->_RecordCache->set( $key, $self->_serialize ); return 1; } sub _serialize { my $self = shift; return { values => $self->{'values'}, table => $self->Table, fetched => $self->{'fetched'} }; } # Function: _gen_alternate_RecordCache_key # Type : private instance # Args : hash (attr) # Lvalue : 1 # Desc : Takes a perl hash and generates a key from it. sub _gen_alternate_RecordCache_key { my ( $self, %attr ) = @_; my $cache_key = ''; foreach my $key ( sort keys %attr ) { my $value = $attr{$key}; unless ( defined $value ) { $value = '=__undef'; } elsif ( ref($value) eq "HASH" ) { $value = ( $value->{operator} || '=' ) . ( defined $value->{value}? $value->{value}: '__undef' ); } else { $value = "=" . $value; } $cache_key .= $key . $value . ','; } chop($cache_key); return ($cache_key); } # Function: _primary_RecordCache_key # Type : private instance # Args : none # Lvalue: : 1 # Desc : generate a primary-key based variant of this object's cache key # primary keys is in the cache sub _primary_RecordCache_key { my ($self) = @_; return $self->{'_SB_Record_Primary_RecordCache_key'} if $self->{'_SB_Record_Primary_RecordCache_key'}; my $cache_key = ''; my %pk = $self->PrimaryKeys; foreach my $key ( sort keys %pk ) { my $value = $pk{$key}; return undef unless defined $value; $cache_key .= $key . '=' . $value .','; } chop $cache_key; return $self->{'_SB_Record_Primary_RecordCache_key'} = $cache_key; } # Function: lookup_primary_RecordCache_key # Type : private class # Args : string(alternate cache id) # Lvalue : string(cache id) sub _lookup_primary_RecordCache_key { my ($self, $key) = @_; return undef unless $key; return $self->_KeyCache->fetch($key) || $key; } =head2 _CacheConfig You can override this method to change the duration of the caching from the default of 5 seconds. For example, to cache records for up to 30 seconds, add the following method to your class: sub _CacheConfig { { 'cache_for_sec' => 30 } } =cut sub _CacheConfig { return { 'cache_for_sec' => 5, }; } 1; __END__ =head1 AUTHOR Matt Knopp =head1 SEE ALSO L, L =cut DBIx-SearchBuilder-1.71/t/pod.t000644 000765 000024 00000000201 13275205765 017027 0ustar00sunnavystaff000000 000000 use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); DBIx-SearchBuilder-1.71/t/02null_order.t000644 000765 000024 00000010106 14123431434 020544 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 11; 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 ); unless ( $handle->HasSupportForNullsOrder ) { skip "Feature is not supported by $d", TESTS_PER_DRIVER; } 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 ); $users_obj->UnLimit; # NULLs are small $handle->NullsOrder('small'); $users_obj->OrderBy(FIELD => 'Value', ORDER => 'ASC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ undef, 0, 1 ], ; $users_obj->OrderBy(FIELD => 'Value', ORDER => 'DESC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ 1, 0, undef ], ; # NULLs are large $handle->NullsOrder('large'); $users_obj->OrderBy(FIELD => 'Value', ORDER => 'ASC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ 0, 1, undef ], ; $users_obj->OrderBy(FIELD => 'Value', ORDER => 'DESC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ undef, 1, 0, ], ; # NULLs are first $handle->NullsOrder('first'); $users_obj->OrderBy(FIELD => 'Value', ORDER => 'ASC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ undef, 0, 1 ], ; $users_obj->OrderBy(FIELD => 'Value', ORDER => 'DESC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ undef, 1, 0, ], ; # NULLs are last $handle->NullsOrder('last'); $users_obj->OrderBy(FIELD => 'Value', ORDER => 'ASC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ 0, 1, undef ], ; $users_obj->OrderBy(FIELD => 'Value', ORDER => 'DESC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ 1, 0, undef ], ; cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql {[ "DROP TABLE IF EXISTS Users", <Table('Users'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Value => {read => 1, write => 1, type => 'int(11)' }, } } sub init_data { return ( [ 'Value', ], [ undef, ], [ 0, ], [ 1, ], ); } 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; DBIx-SearchBuilder-1.71/t/02records_object.t000644 000765 000024 00000007420 14123431434 021373 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 11; 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 $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_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 ) } ] } sub schema_oracle { [ "CREATE SEQUENCE Employees_seq", "CREATE TABLE Employees ( id integer CONSTRAINT Employees_Key PRIMARY KEY, Name varchar(36) )", "CREATE SEQUENCE Phones_seq", "CREATE TABLE Phones ( id integer CONSTRAINT Phones_Key PRIMARY KEY, Employee integer NOT NULL, Phone varchar(18) )", ] } sub cleanup_schema_oracle { [ "DROP SEQUENCE Employees_seq", "DROP TABLE Employees", "DROP SEQUENCE Phones_seq", "DROP TABLE Phones", ] } package TestApp::Employee; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; use vars qw/$VERSION/; $VERSION=0.01; sub _Init { my $self = shift; my $handle = shift; $self->Table('Employees'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, Name => {read => 1, write => 1, type => 'varchar(18)'}, } } 1; package TestApp::Phone; use vars qw/$VERSION/; $VERSION=0.01; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Phones'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, Employee => {read => 1, write => 1, type => 'int(11)', object => 'TestApp::Employee' }, Value => {read => 1, write => 1, type => 'varchar(18)'}, } } 1; DBIx-SearchBuilder-1.71/t/03compatibility.t000644 000765 000024 00000001374 14123431434 021260 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 2; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; my %QUOTE_CHAR = (); foreach my $d ( @AvailableDrivers ) { SKIP: { 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 $dbh = $handle->dbh; my $q = $QUOTE_CHAR{$d} || "'"; # was problem in DBD::Pg, fixed in 1.40 back in 2005 is( $dbh->quote("\x{420}"), "$q\x{420}$q", "->quote don't clobber UTF-8 flag"); }} # SKIP, foreach blocks 1; DBIx-SearchBuilder-1.71/t/01nocap_api.t000644 000765 000024 00000001713 14123431434 020333 0ustar00sunnavystaff000000 000000 #!/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); } DBIx-SearchBuilder-1.71/t/04mysql_identifier_quoting.t000644 000765 000024 00000001112 14031554557 023525 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 7; BEGIN { use_ok("DBIx::SearchBuilder::Handle"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::mysql"); } my $h = DBIx::SearchBuilder::Handle::mysql->new(); is ($h->QuoteName('foo'), '`foo`', 'QuoteName works as expected'); is ($h->DequoteName('`foo`'), 'foo', 'DequoteName works as expected'); is ($h->DequoteName('`foo'), '`foo', 'DequoteName works as expected'); is ($h->DequoteName('foo`'), 'foo`', 'DequoteName works as expected'); is ($h->DequoteName('"foo"'), '"foo"', 'DequoteName works as expected'); DBIx-SearchBuilder-1.71/t/03rebless.t000644 000765 000024 00000001375 14123431434 020047 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; 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; DBIx-SearchBuilder-1.71/t/01records.t000644 000765 000024 00000022026 14123431434 020043 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 66; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; 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 $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'); # Handle->Fields is_deeply( [$handle->Fields('Address')], [qw(id name phone employeeid)], "listed all columns in the table" ); is_deeply( [$handle->Fields('Some')], [], "no table -> no fields" ); # _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('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'); 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"); 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"); # 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"); # Validate truncation 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, '這是個測'); # 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"); # make sure we do truncation on create 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"); like($msg, qr/^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"); ( $val, $msg ) = $rec->SetName(); ok( $val, $msg ); is( $rec->Name, undef, "no value means null"); # 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 1; package TestApp::Address; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Address'); $self->_Handle($handle); } sub ValidateName { my ($self, $value) = @_; return 1 unless defined $value; return 0 if $value =~ /invalid/i; return 1; } sub _ClassAccessible { { id => {read => 1, type => 'int(11)', default => ''}, Name => {read => 1, write => 1, type => 'varchar(14)', default => ''}, Phone => {read => 1, write => 1, type => 'varchar(18)', length => 18, default => ''}, EmployeeId => {read => 1, write => 1, type => 'int(8)', default => ''}, } } sub schema_mysql { < 20; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; 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 $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); my ($id) = $rec->Create( Name => 'foo', Counter => 3 ); ok( $id, "Created record " . $id ); ok( $rec->Load($id), "Loaded the record" ); is( $rec->Name, 'foo', "name is foo" ); is( $rec->Counter, 3, "number is 3" ); my ( $val, $msg ) = $rec->SetName('bar'); ok( $val, $msg ); is( $rec->Name, 'bar', "name is changed to bar" ); ( $val, $msg ) = $rec->SetName(undef); ok( !$val, $msg ); like( $msg, qr/Illegal value for non-nullable field Name/, 'error message' ); is( $rec->Name, 'bar', 'name is still bar' ); SKIP: { skip 'Oracle treats the empty string as a NULL' => 2 if $d eq 'Oracle'; ( $val, $msg ) = $rec->SetName(''); ok( $val, $msg ); is( $rec->Name, '', "name is changed to ''" ); } ( $val, $msg ) = $rec->SetCounter(42); ok( $val, $msg ); is( $rec->Counter, 42, 'number is changed to 42' ); ( $val, $msg ) = $rec->SetCounter(undef); ok( !$val, $msg ); like( $msg, qr/Illegal value for non-nullable field Counter/, 'error message' ); is( $rec->Counter, 42, 'number is still 42' ); ( $val, $msg ) = $rec->SetCounter(''); ok( $val, $msg ); is( $rec->Counter, 0, 'empty string implies 0 for integer field' ); cleanup_schema( 'TestApp::Address', $handle ); } } 1; package TestApp::Address; use base $ENV{SB_TEST_CACHABLE} ? qw/DBIx::SearchBuilder::Record::Cachable/ : qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Address'); $self->_Handle($handle); } sub _ClassAccessible { { id => { read => 1, type => 'int(11)', }, Name => { read => 1, write => 1, type => 'varchar(14)', no_nulls => 1 }, Counter => { read => 1, write => 1, type => 'int(8)', no_nulls => 1 }, }; } sub schema_mysql { < 37; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; 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 $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 $id = $rec->Create; ok($id, 'created record'); $rec->Load( $id ); is($rec->id, $id, 'loaded record'); is($rec->Optional, undef, 'correct value'); is($rec->Mandatory, 1, 'correct value'); } { my $rec = TestApp::Address->new($handle); isa_ok($rec, 'DBIx::SearchBuilder::Record'); my $id = $rec->Create( Mandatory => undef ); ok($id, 'created record'); $rec->Load( $id ); is($rec->id, $id, 'loaded record'); is($rec->Optional, undef, 'correct value'); is($rec->Mandatory, 1, 'correct value, we have default'); } { my $rec = TestApp::Address->new($handle); isa_ok($rec, 'DBIx::SearchBuilder::Record'); # Pg doesn't like "int_column = ''" syntax my $id = $rec->Create( Optional => '' ); ok($id, 'created record'); $rec->Load( $id ); is($rec->id, $id, 'loaded record'); is($rec->Optional, 0, 'correct value, fallback to 0 for empty string'); is($rec->Mandatory, 1, 'correct value, we have default'); # set operations on optional field my $status = $rec->SetOptional( 1 ); ok($status, "status ok") or diag $status->error_message; is($rec->Optional, 1, 'set optional field to 1'); $status = $rec->SetOptional( undef ); ok($status, "status ok") or diag $status->error_message; is($rec->Optional, undef, 'undef equal to NULL'); { my $warn; local $SIG{__WARN__} = sub { $warn++; warn @_; }; $status = $rec->SetOptional(''); ok( $status, "status ok" ) or diag $status->error_message; is( $rec->Optional, 0, 'empty string should be threated as zero' ); ok( !$warn, 'no warning to set value from null to not-null' ); } $status = $rec->SetOptional; ok($status, "status ok") or diag $status->error_message; is($rec->Optional, undef, 'no value is NULL too'); $status = $rec->SetOptional; ok(!$status, 'same null value set'); is( ( $status->as_array )[1], "That is already the current value", "correct error message" ); is($rec->Optional, undef, 'no value is NULL too'); # set operations on mandatory field $status = $rec->SetMandatory( 2 ); ok($status, "status ok") or diag $status->error_message; is($rec->Mandatory, 2, 'set optional field to 2'); $status = $rec->SetMandatory( undef ); ok($status, "status ok") or diag $status->error_message; is($rec->Mandatory, 1, 'fallback to default'); $status = $rec->SetMandatory( '' ); ok($status, "status ok") or diag $status->error_message; is($rec->Mandatory, 0, 'empty string should be threated as zero'); $status = $rec->SetMandatory; ok($status, "status ok") or diag $status->error_message; is($rec->Mandatory, 1, 'no value on set also fallback'); } cleanup_schema( 'TestApp::Address', $handle ); }} # SKIP, foreach blocks package TestApp::Address; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('MyTable'); $self->_Handle($handle); } sub _ClassAccessible { { id => { read => 1, type => 'int(11)' }, Optional => { read => 1, write => 1, type => 'int(11)' }, Mandatory => { read => 1, write => 1, type => 'int(11)', default => 1, no_nulls => 1 }, } } sub schema_mysql { < 4; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { use_ok('DBIx::SearchBuilder::Handle::'. $d); my $handle = get_handle( $d ); isa_ok($handle, 'DBIx::SearchBuilder::Handle'); isa_ok($handle, 'DBIx::SearchBuilder::Handle::'. $d); can_ok($handle, 'dbh'); } } 1; DBIx-SearchBuilder-1.71/t/02distinct_values.t000644 000765 000024 00000007455 14123431434 021614 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 9; 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; } diag "testing $d" if $ENV{TEST_VERBOSE}; 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"); # unlimit new object and check $users_obj->UnLimit; { my @list = qw(boss dev sales); if ( $d eq 'Pg' || $d eq 'Oracle' ) { push @list, undef; } else { unshift @list, undef; } is_deeply( [$users_obj->DistinctFieldValues('GroupName', Order => 'ASC')], [@list], 'Correct list' ); is_deeply( [$users_obj->DistinctFieldValues('GroupName', Order => 'DESC')], [reverse @list], 'Correct list' ); $users_obj->CleanSlate; } $users_obj->Limit( FIELD => 'Login', OPERATOR => 'LIKE', VALUE => 'k' ); is_deeply( [$users_obj->DistinctFieldValues('GroupName', Order => 'ASC')], [qw(dev sales)], 'Correct list' ); is_deeply( [$users_obj->DistinctFieldValues('GroupName', Order => 'DESC')], [reverse qw(dev sales)], 'Correct list' ); cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql { <Table('Users'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Login => {read => 1, write => 1, type => 'varchar(18)' }, GroupName => {read => 1, write => 1, type => 'varchar(36)' }, } } sub init_data { return ( [ 'Login', 'GroupName' ], [ 'cubic', 'dev' ], [ 'obra', 'boss' ], [ 'kevin', 'dev' ], [ 'keri', 'sales' ], [ 'some', undef ], ); } 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; DBIx-SearchBuilder-1.71/t/11schema_records.t000644 000765 000024 00000017253 14123431434 021372 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 66; 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); } ok( $phone3->Delete, "Deleted phone $p3_id" ); my $group = TestApp::Group->new($handle); my $g_id = $group->Create( Name => 'Employees' ); ok( $g_id, "Got an id for the new group: $g_id" ); $group->Load($g_id); is( $group->id, $g_id, "loaded group ok" ); 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) ) }, q{CREATE TABLE Groups ( id integer primary key, Name varchar(36) ) } ] } 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) ) }, q{CREATE TEMPORARY TABLE `Groups` ( id integer AUTO_INCREMENT primary key, Name varchar(36) ) } ] } 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 ) }, q{CREATE TEMPORARY TABLE Groups ( id serial primary key, Name varchar ) } ] } package TestApp::Employee; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: 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 $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: 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 ); } package TestApp::Group; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub Table { 'Groups' } sub Schema { return { Name => { TYPE => 'varchar' }, } } package TestApp::GroupCollection; 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::Group'; return $class->new( $self->_Handle ); } 1; DBIx-SearchBuilder-1.71/t/03versions.t000644 000765 000024 00000002106 14123431434 020251 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; use DBIx::SearchBuilder::Handle; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 6; 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 = get_handle( $d ); ok($handle, "Made a handle"); isa_ok($handle, 'DBIx::SearchBuilder::Handle'); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); my $full_version = $handle->DatabaseVersion( Short => 0 ); diag("Full version is '$full_version'") if defined $full_version && $ENV{'TEST_VERBOSE'}; ok($full_version, "returns full version"); my $short_version = $handle->DatabaseVersion; diag("Short version is '$short_version'") if defined $short_version && $ENV{'TEST_VERBOSE'}; ok($short_version, "returns short version"); like($short_version, qr{^[-\w\.]+$}, "short version has only \\w.-"); }} # SKIP, foreach blocks 1; DBIx-SearchBuilder-1.71/t/02records_cachable.t000644 000765 000024 00000006551 14123431434 021653 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 16; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; 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 $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 ($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"); my $rec_cache = TestApp::Address->new($handle); my ($status, $msg) = $rec_cache->LoadById($id); ok($status, 'loaded record'); is($rec_cache->id, $id, 'the same record as we created'); is($msg, 'Fetched from cache', 'we fetched record from cache'); DBIx::SearchBuilder::Record::Cachable->FlushCache; ok($rec->LoadByCols( Name => 'Jesse' ), "Loaded the record"); is($rec->id, $id, "The record has its id"); is($rec->Name, 'Jesse', "The record's name is Jesse"); $rec_cache = TestApp::Address->new($handle); ($status, $msg) = $rec_cache->LoadById($id); ok($status, 'loaded record'); is($rec_cache->id, $id, 'the same record as we created'); is($msg, 'Fetched from cache', 'we fetched record from cache'); cleanup_schema( 'TestApp::Address', $handle ); }} # SKIP, foreach blocks 1; package TestApp::Address; use base qw/DBIx::SearchBuilder::Record::Cachable/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Address'); $self->_Handle($handle); } sub _ClassAccessible { return { id => {read => 1, type => 'int(11)', default => ''}, Name => {read => 1, write => 1, type => 'varchar(14)', default => ''}, Phone => {read => 1, write => 1, type => 'varchar(18)', length => 18, default => ''}, EmployeeId => {read => 1, write => 1, type => 'int(8)', default => ''}, } } sub _CacheConfig { return { 'cache_for_sec' => 60, }; } sub schema_mysql { < 17; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; my $handle; 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; } $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); diag "testing $d" if $ENV{'TEST_VERBOSE'}; 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 = TestApp::Users->new( $handle ); $users->UnLimit; $users->Column( FIELD => 'Result' ); my $column = $users->Column( FUNCTION => $users->_Handle->DateTimeIntervalFunction( From => 'Created', To => 'Resolved' ), ); while ( my $user = $users->Next ) { is $user->__Value( $column ), $user->Result; } $users = TestApp::Users->new( $handle ); $users->UnLimit; $users->Column( FIELD => 'Result' ); $column = $users->Column( FUNCTION => $users->_Handle->DateTimeIntervalFunction( From => { FIELD => 'Created' }, To => { FIELD => 'Resolved' }, ), ); while ( my $user = $users->Next ) { is $user->__Value( $column ), $user->Result; } cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql { <Table('Users'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Created => {read => 1, write => 1, type => 'datetime' }, Resolved => {read => 1, write => 1, type => 'datetime' }, Result => {read => 1, type => 'int(11)' }, } } sub init_data { return ( [ 'Created', 'Resolved', 'Result' ], [ undef, undef , undef ], [ undef , '2011-05-20 19:53:23', undef ], [ '2011-05-20 19:53:23', undef , undef ], [ '2011-05-20 19:53:23', '2011-05-20 19:53:23', 0], [ '2011-05-20 19:53:23', '2011-05-21 20:54:24', 1*24*60*60+1*60*60+1*60+1], [ '2011-05-20 19:53:23', '2011-05-19 18:52:22', -(1*24*60*60+1*60*60+1*60+1)], [ '2011-05-20 19:53:23', '2012-09-20 19:53:23', 42249600], ); } 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; DBIx-SearchBuilder-1.71/t/utils.pl000644 000765 000024 00000010651 13275205765 017567 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use File::Temp qw/ tempdir /; use File::Spec; =head1 VARIABLES =head2 @SupportedDrivers Array of all supported DBD drivers. =cut our @SupportedDrivers = qw( Informix mysql mysqlPP ODBC Oracle Pg SQLite 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 { my $type = shift; my $class = 'DBIx::SearchBuilder::Handle::'. $type; eval "require $class"; die $@ if $@; my $handle; $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 into a C on C. =cut sub connect_handle_with_driver { my $call = "connect_". lc $_[1]; return unless defined &$call; @_ = $_[0]; goto &$call; } sub connect_sqlite { my $dir = tempdir(CLEANUP => 1); my $handle = shift; return $handle->Connect( Driver => 'SQLite', Database => File::Spec->catfile($dir => "db.sqlite") ); } 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'} || '', ); } sub connect_oracle { my $handle = shift; return $handle->Connect( Driver => 'Oracle', Database => $ENV{'SB_TEST_ORACLE'}, Host => $ENV{'SB_TEST_ORACLE_HOST'}, SID => $ENV{'SB_TEST_ORACLE_SID'}, User => $ENV{'SB_TEST_ORACLE_USER'} || 'test', Password => $ENV{'SB_TEST_ORACLE_PASS'} || 'test', ); } =head2 should_test Checks environment for C 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 method of the C<$class>. Returns last C 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 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; DBIx-SearchBuilder-1.71/t/02order_outer.t000644 000765 000024 00000012737 14123431434 020744 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 98; 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 $lowest = ($d ne 'Pg' && $d ne 'Oracle')? '-': 'z'; diag "generate data" if $ENV{TEST_VERBOSE}; { my @tags = qw(a b c d); foreach my $i ( 1..30 ) { my $number_of_tags = int(rand(4)); my @t; push @t, $tags[int rand scalar @tags] while $number_of_tags--; my %seen = (); @t = grep !$seen{$_}++, @t; my $obj = TestApp::Object->new($handle); my ($oid) = $obj->Create( Name => join(",", sort @t) || $lowest ); ok($oid,"Created record ". $oid); ok($obj->Load($oid), "Loaded the record"); my $tags_ok = 1; foreach my $t( @t ) { my $tag = TestApp::Tag->new($handle); my ($tid) = $tag->Create( Object => $oid, Name => $t ); $tags_ok = 0 unless $tid; } ok($tags_ok, "Added tags"); } } # ASC order foreach my $direction ( qw(ASC DESC) ) { my $objs = TestApp::Objects->new($handle); $objs->UnLimit; my $tags_alias = $objs->Join( TYPE => 'LEFT', ALIAS1 => 'main', FIELD1 => 'id', TABLE2 => 'Tags', FIELD2 => 'Object', ); ok($tags_alias, "joined tags table"); $objs->OrderBy( ALIAS => $tags_alias, FIELD => 'Name', ORDER => $direction ); ok($objs->First, 'ok, we have at least one result'); $objs->GotoFirstItem; my ($order_ok, $last) = (1, $direction eq 'ASC'? '-': 'zzzz'); while ( my $obj = $objs->Next ) { my $tmp; if ( $direction eq 'ASC' ) { $tmp = (substr($last, 0, 1) cmp substr($obj->Name, 0, 1)); } else { $tmp = -(substr($last, -1, 1) cmp substr($obj->Name, -1, 1)); } if ( $tmp > 0 ) { $order_ok = 0; last; } $last = $obj->Name; } ok($order_ok, "$direction order is correct") or do { diag "Wrong $direction query: ". $objs->BuildSelectQuery; $objs->GotoFirstItem; while ( my $obj = $objs->Next ) { diag($obj->id .":". $obj->Name); } } } cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql { [ "CREATE TEMPORARY TABLE Objects ( id integer AUTO_INCREMENT, Name varchar(36), PRIMARY KEY (id) )", "CREATE TEMPORARY TABLE Tags ( id integer AUTO_INCREMENT, Object integer NOT NULL, Name varchar(36), PRIMARY KEY (id) )", ] } sub schema_pg { [ "CREATE TEMPORARY TABLE Objects ( id serial PRIMARY KEY, Name varchar(36) )", "CREATE TEMPORARY TABLE Tags ( id serial PRIMARY KEY, Object integer NOT NULL, Name varchar(36) )", ]} sub schema_sqlite {[ "CREATE TABLE Objects ( id integer primary key, Name varchar(36) )", "CREATE TABLE Tags ( id integer primary key, Object integer NOT NULL, Name varchar(36) )", ]} sub schema_oracle { [ "CREATE SEQUENCE Objects_seq", "CREATE TABLE Objects ( id integer CONSTRAINT Objects_Key PRIMARY KEY, Name varchar(36) )", "CREATE SEQUENCE Tags_seq", "CREATE TABLE Tags ( id integer CONSTRAINT Tags_Key PRIMARY KEY, Object integer NOT NULL, Name varchar(36) )", ] } sub cleanup_schema_oracle { [ "DROP SEQUENCE Objects_seq", "DROP TABLE Objects", "DROP SEQUENCE Tags_seq", "DROP TABLE Tags", ] } 1; package TestApp::Object; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Objects'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Name => {read => 1, write => 1, type => 'varchar(36)' }, } } 1; package TestApp::Objects; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); $self->Table('Objects'); } sub NewItem { my $self = shift; return TestApp::Object->new( $self->_Handle ); } 1; package TestApp::Tag; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Tags'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Object => {read => 1, type => 'int(11)' }, Name => {read => 1, write => 1, type => 'varchar(36)' }, } } 1; package TestApp::Tags; # use TestApp::User; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); $self->Table('Tags'); } sub NewItem { my $self = shift; return TestApp::Tag->new( $self->_Handle ); } 1; DBIx-SearchBuilder-1.71/t/01searches.t000644 000765 000024 00000051236 14123431434 020204 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 150; 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 First/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" ); # IN [...] operator $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => ['obra', 'cubic'] ); is( $users_obj->Count, 2, "found two users using IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'cubic', 'obra' ], 'found correct records', ); $users_obj->CleanSlate; $users_obj->Limit( FIELD => 'Login', OPERATOR => 'NOT IN', VALUE => ['obra', 'cubic'] ); is( $users_obj->Count, 2, "found two users using NOT IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'autrijus', 'glasser' ], 'found correct records', ); # IN $collection operator $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); { my $tmp = $users_obj->Clone; $tmp->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => ['obra', 'cubic'] ); $users_obj->Limit( FIELD => 'id', OPERATOR => 'IN', VALUE => $tmp ); } is( $users_obj->Count, 2, "found two users using IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'cubic', 'obra' ], 'found correct records', ); $users_obj->CleanSlate; { my $tmp = $users_obj->Clone; $tmp->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => ['obra', 'cubic'] ); $users_obj->Limit( FIELD => 'id', OPERATOR => 'NOT IN', VALUE => $tmp ); } is( $users_obj->Count, 2, "found two users using IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'autrijus', 'glasser' ], 'found correct records', ); # IN with object and Column preselected $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); { my $tmp = $users_obj->Clone; $tmp->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => ['obra', 'cubic'] ); $tmp->Column(FIELD => 'Login'); $users_obj->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => $tmp ); } is( $users_obj->Count, 2, "found two users using IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'cubic', 'obra' ], 'found correct records', ); # 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' ); $users_obj->CleanSlate; TODO: { local $TODO = 'we leave order_by after clean slate, fixing this results in many RT failures'; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); } { $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->GroupBy({FUNCTION => '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' ); } { $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->GroupBy({FUNCTION => 'SUBSTR(Login, 1, 1)', }); $users_obj->Column(FIELD => 'Login', FUNCTION => 'SUBSTR(Login, 1, 1)'); my @list = sort map $_->Login, @{ $users_obj->ItemsArrayRef }; is_deeply( \@list, [qw(a c g o)], 'correct values' ); } { $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->GroupBy({FUNCTION => 'SUBSTR(?, 1, 1)', FIELD => 'Login'}); $users_obj->Column(FIELD => 'Login', FUNCTION => 'SUBSTR(?, 1, 1)'); my @list = sort map $_->Login, @{ $users_obj->ItemsArrayRef }; is_deeply( \@list, [qw(a c g o)], 'correct values' ); } $users_obj = TestApp::Users->new( $handle ); # Let's play a little with ENTRYAGGREGATOR # EA defaults to OR for the same field $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'IS', VALUE => 'NULL', QOUTEVALUE => 0 ); $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'LIKE', VALUE => 'X' ); is( $users_obj->Count, 4, "found users who has no phone or it has X char" ); # set AND for the same field $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Login', OPERATOR => 'NOT LIKE', VALUE => 'c' ); $users_obj->Limit( ENTRYAGGREGATOR => 'AND', FIELD => 'Login', OPERATOR => 'LIKE', VALUE => 'u' ); is( $users_obj->Count, 1, "found users who has no phone or it has X char" ); # default is AND for different fields $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'IS', VALUE => 'NULL', QOUTEVALUE => 0 ); $users_obj->Limit( FIELD => 'Login', OPERATOR => 'LIKE', VALUE => 'r' ); is( $users_obj->Count, 2, "found users who has no phone number or login has 'r' char" ); # Let's play with RowsPerPage # RowsPerPage(0) # https://rt.cpan.org/Ticket/Display.html?id=42988 $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->UnLimit; $users_obj->RowsPerPage(0); is( $users_obj->Count, $count_all, "found all users" ); ok( $users_obj->First, "fetched first user" ); # walk all pages $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->UnLimit; $users_obj->OrderBy(FIELD => 'Login'); $users_obj->RowsPerPage(2); { my %seen; my $saw_on_page = 0; my $pages = 0; my $prev_login = ''; do { $saw_on_page = 0; while ( my $user = $users_obj->Next ) { $saw_on_page++; $seen{ $user->id }++; ok( $prev_login lt $user->Login, "order is correct" ); } last unless $saw_on_page; $pages++; if ( $pages * 2 <= $count_all ) { is( $saw_on_page, 2, "saw only two on the page" ); } else { is( $saw_on_page, $count_all - ($pages * 2), "saw slightly less users on the last page"); } $users_obj->NextPage; } while ( $saw_on_page ); ok( !grep( $_ != 1, values %seen ), "saw each user only once") or do { use Data::Dumper; diag Dumper(\%seen) }; is( scalar keys %seen, $count_all, "saw all users" ) } # two steps forward, on step back $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->OrderBy(FIELD => 'Login'); $users_obj->RowsPerPage(1); for ( 1 .. $count_all-1) { my $u = $users_obj->Next; ok( $u, "got a user"); ok(!$users_obj->Next, "only on the page"); $users_obj->NextPage; isnt( $users_obj->Next->id, $u->id, "got a user and he is different"); ok(!$users_obj->Next, "only on the page"); $users_obj->PrevPage; is( $users_obj->Next->id, $u->id, "got a user and he is the same"); ok(!$users_obj->Next, "only on the page"); $users_obj->NextPage; } # tricky variant: skip 1, but show 2 $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->OrderBy(FIELD => 'Login'); $users_obj->RowsPerPage(2); $users_obj->FirstRow(2); { my $u = $users_obj->Next; is( $u->Login, 'cubic', "cubic is second in the list"); } { my $u = $users_obj->Next; is( $u->Login, 'glasser', "glasser is third in the list"); } # Let's play with Column $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( $users_obj->Column(FIELD => 'id'), 'id' ); isnt( my $id_alias = $users_obj->Column(FIELD => 'id'), 'id' ); my $u = $users_obj->Next; is ( $u->_Value($id_alias), $u->id, "fetched id twice" ); } $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( $users_obj->Column(FIELD => 'id'), 'id' ); isnt( my $id_alias = $users_obj->Column(FIELD => 'id', FUNCTION => '? + 1'), 'id' ); my $u = $users_obj->Next; is ( $u->_Value($id_alias), $u->id + 1, "fetched id and function based on id" ) or diag "wrong SQL: ". $users_obj->BuildSelectQuery; } $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( $users_obj->Column(FIELD => 'id'), 'id' ); isnt( my $id_alias = $users_obj->Column(FUNCTION => 'id + 1'), 'id' ); my $u = $users_obj->Next; is ( $u->_Value($id_alias), $u->id + 1, "fetched id and function based on id" ); } $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( $users_obj->Column(FIELD => 'id'), 'id' ); isnt( my $id_alias = $users_obj->Column(FUNCTION => '?', FIELD => 'id'), 'id' ); my $u = $users_obj->Next; is ( $u->_Value($id_alias), $u->id, "fetched with '?' function" ); } $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( $users_obj->Column(FIELD => 'id'), "id" ); is( my $id_alias = $users_obj->Column(FIELD => 'id', AS => 'foo'), "foo" ); my $u = $users_obj->Next; is( $u->_Value($id_alias), $u->id, "fetched id with custom alias" ); } $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( $users_obj->Column(FUNCTION => "main.*", AS => undef), undef ); my $u = $users_obj->Next; ok $u->{fetched}{"\L$_"}, "fetched field $_" for keys %{$u->_ClassAccessible}; } $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( my $id_alias = $users_obj->AdditionalColumn(FIELD => 'id', AS => 'foo'), "foo" ); my $u = $users_obj->Next; is( $u->_Value($id_alias), $u->id, "fetched id with custom alias" ); ok $u->{fetched}{"\L$_"}, "fetched normal field $_" for keys %{$u->_ClassAccessible}; } # Last without running the search first $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->OrderBy( FIELD => "Login", ORDER => "ASC" ); is $users_obj->Last->Login, "obra", "Found last record correctly before search was run"; cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql {[ "DROP TABLE IF EXISTS Users", <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; DBIx-SearchBuilder-1.71/t/03searches_bind.t000644 000765 000024 00000022414 14123431434 021176 0ustar00sunnavystaff000000 000000 use strict; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 39; 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_users = init_data( 'TestApp::User', $handle ); ok( $count_users, "init users data" ); my $count_groups = init_data( 'TestApp::Group', $handle ); ok( $count_groups, "init groups data" ); my $count_us2gs = init_data( 'TestApp::UsersToGroup', $handle ); ok( $count_us2gs, "init users&groups relations data" ); my $clean_obj = TestApp::Users->new($handle); local $DBIx::SearchBuilder::PREFER_BIND = 1; my $users_obj = $clean_obj->Clone; for my $login ( 'Gandalf', "Bilbo\\Baggins", "Baggins' Frodo" ) { $users_obj->Limit( FIELD => 'Login', VALUE => $login ); is( $users_obj->Count, 1, "only one value" ); is( $users_obj->First->Login, $login, "$login is the only match" ); # Using \W here because Login might be wrapped in LOWER(). ok( $users_obj->BuildSelectQuery =~ /Login\W*=\s*\?/i, 'found a placeholder in select query' ); ok( $users_obj->BuildSelectCountQuery =~ /Login\W*=\s*\?/i, 'found a placeholder in select count query' ); $users_obj->CleanSlate; } $users_obj->Limit( FIELD => 'Login', VALUE => [ "Bilbo\\Baggins", "Baggins' Frodo" ], OPERATOR => 'IN', ); is( $users_obj->Count, 2, "2 values" ); is_deeply( [ sort map { $_->Login } @{ $users_obj->ItemsArrayRef } ], [ "Baggins' Frodo", "Bilbo\\Baggins" ], '2 Baggins', ); $users_obj->CleanSlate; for my $name ( "Shire's Bag End", 'The Fellowship of the Ring' ) { my $groups_obj = TestApp::Groups->new($handle); $groups_obj->Limit( FIELD => 'Name', VALUE => $name, OPERATOR => 'LIKE' ); $groups_obj->Limit( FIELD => 'id', VALUE => 0, OPERATOR => '>' ); is( $groups_obj->Count, 1, "only one value" ); is( $groups_obj->First->Name, $name, "$name is the only match" ); # Using \W here because Login might be wrapped in LOWER(). ok( $groups_obj->BuildSelectQuery =~ /Name\W*I?LIKE\s*\?/i, 'found a placeholder for Name in select query' ); ok( $groups_obj->BuildSelectQuery =~ /id\s*>\s*\?/i, 'found a placeholder for id in select query' ); ok( $groups_obj->BuildSelectCountQuery =~ /Name\W*I?LIKE\s*\?/i, 'found a placeholder for Name in select count query' ); ok( $groups_obj->BuildSelectCountQuery =~ /id\s*>\s*\?/i, 'found a placeholder for id in select count query' ); } my $alias = $users_obj->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); my $group_alias = $users_obj->Join( ALIAS1 => $alias, FIELD1 => 'GroupID', ALIAS2 => $users_obj->NewAlias('Groups'), FIELD2 => 'id' ); $users_obj->Limit( LEFTJOIN => $group_alias, FIELD => 'Name', VALUE => "Shire's Bag End", ); is( $users_obj->Count, 2, "2 values" ); is_deeply( [ sort map { $_->Login } @{ $users_obj->ItemsArrayRef } ], [ "Baggins' Frodo", "Bilbo\\Baggins" ], '2 Baggins', ); # ? in JOIN condition ok( $users_obj->BuildSelectQuery( PreferBind => 0 ) !~ /\?/, 'found placeholder in select query' ); ok( $users_obj->BuildSelectCountQuery( PreferBind => 0 ) !~ /\?/, 'found placeholder in select count query' ); ok( $users_obj->BuildSelectQuery( PreferBind => 0 ) !~ /\?/, 'no placeholder in select query' ); ok( $users_obj->BuildSelectCountQuery( PreferBind => 0 ) !~ /\?/, 'no placeholder in select count query' ); $DBIx::SearchBuilder::PREFER_BIND = 0; ok( $users_obj->BuildSelectQuery !~ /\?/, 'no placeholder in select query' ); ok( $users_obj->BuildSelectCountQuery !~ /\?/, 'no placeholder in select count query' ); cleanup_schema( 'TestApp', $handle ); } } # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE TABLE Users ( id integer primary key, Login varchar(36) ) }, q{ CREATE TABLE UsersToGroups ( id integer primary key, UserId integer, GroupId integer ) }, q{ CREATE TABLE Groups ( id integer primary key, Name varchar(36) ) }, ] } sub schema_mysql { [ q{ CREATE TEMPORARY TABLE Users ( id integer primary key AUTO_INCREMENT, Login varchar(36) ) }, q{ CREATE TEMPORARY TABLE UsersToGroups ( id integer primary key AUTO_INCREMENT, UserId integer, GroupId integer ) }, q{ CREATE TEMPORARY TABLE `Groups` ( id integer primary key AUTO_INCREMENT, Name varchar(36) ) }, ] } sub schema_pg { [ q{ CREATE TEMPORARY TABLE Users ( id serial primary key, Login varchar(36) ) }, q{ CREATE TEMPORARY TABLE UsersToGroups ( id serial primary key, UserId integer, GroupId integer ) }, q{ CREATE TEMPORARY TABLE Groups ( id serial primary key, Name varchar(36) ) }, ] } sub schema_oracle { [ "CREATE SEQUENCE Users_seq", "CREATE TABLE Users ( id integer CONSTRAINT Users_Key PRIMARY KEY, Login varchar(36) )", "CREATE SEQUENCE UsersToGroups_seq", "CREATE TABLE UsersToGroups ( id integer CONSTRAINT UsersToGroups_Key PRIMARY KEY, UserId integer, GroupId integer )", "CREATE SEQUENCE Groups_seq", "CREATE TABLE Groups ( id integer CONSTRAINT Groups_Key PRIMARY KEY, Name varchar(36) )", ] } sub cleanup_schema_oracle { [ "DROP SEQUENCE Users_seq", "DROP TABLE Users", "DROP SEQUENCE Groups_seq", "DROP TABLE Groups", "DROP SEQUENCE UsersToGroups_seq", "DROP TABLE UsersToGroups", ] } package TestApp::User; use base $ENV{SB_TEST_CACHABLE} ? qw/DBIx::SearchBuilder::Record::Cachable/ : 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(36)' }, } } sub init_data { return ( ['Login'], ['Gandalf'], ["Bilbo\\Baggins"], ["Baggins' Frodo"], ); } package TestApp::Users; 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; package TestApp::Group; use base $ENV{SB_TEST_CACHABLE} ? qw/DBIx::SearchBuilder::Record::Cachable/ : qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Groups'); $self->_Handle($handle); } sub _ClassAccessible { { id => { read => 1, type => 'int(11)' }, Name => { read => 1, write => 1, type => 'varchar(36)' }, } } sub init_data { return ( ['Name'], ["Shire's Bag End"], ['The Fellowship of the Ring'], ); } package TestApp::Groups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); $self->Table('Groups'); } sub NewItem { return TestApp::Group->new( (shift)->_Handle ) } 1; package TestApp::UsersToGroup; use base $ENV{SB_TEST_CACHABLE} ? qw/DBIx::SearchBuilder::Record::Cachable/ : qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('UsersToGroups'); $self->_Handle($handle); } sub _ClassAccessible { { id => { read => 1, type => 'int(11)' }, UserId => { read => 1, type => 'int(11)' }, GroupId => { read => 1, type => 'int(11)' }, } } sub init_data { return ( [ 'GroupId', 'UserId' ], # Shire [ 1, 2 ], [ 1, 3 ], # Fellowship of the Ring [ 2, 1 ], [ 2, 3 ], ); } package TestApp::UsersToGroups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->Table('UsersToGroups'); return $self->SUPER::_Init( Handle => shift ); } sub NewItem { return TestApp::UsersToGroup->new( (shift)->_Handle ) } 1; DBIx-SearchBuilder-1.71/t/03cud_from_select.t000644 000765 000024 00000020055 14123431434 021541 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 14; 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 $groups_table = ($d eq 'mysql') ? '`Groups`' : 'Groups'; 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"); init_data( $_, $handle ) foreach qw( TestApp::User TestApp::Group TestApp::UsersToGroup ); diag "insert into table from other tables only" if $ENV{'TEST_VERBOSE'}; { my $res = $handle->InsertFromSelect( 'UsersToGroups' => ['UserId', 'GroupId'], 'SELECT id, 1 FROM Users WHERE Login LIKE ?', '%o%' ); is( $res, 2 ); my $users = TestApp::Users->new( $handle ); my $alias = $users->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); $users->Limit( ALIAS => $alias, FIELD => 'GroupId', VALUE => 1 ); is_deeply( [ sort map $_->Login, @{ $users->ItemsArrayRef } ], ['bob', 'john'] ); } diag "insert into table from two tables" if $ENV{'TEST_VERBOSE'}; { my $res = $handle->InsertFromSelect( 'UsersToGroups' => ['UserId', 'GroupId'], "SELECT u.id as col1, g.id as col2 FROM Users u, $groups_table g WHERE u.Login LIKE ? AND g.Name = ?", '%a%', 'Support' ); is( $res, 2 ); my $users = TestApp::Users->new( $handle ); my $u2g_alias = $users->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); my $g_alias = $users->Join( ALIAS1 => $u2g_alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id', ); $users->Limit( ALIAS => $g_alias, FIELD => 'Name', VALUE => 'Support' ); is_deeply( [ sort map $_->Login, @{ $users->ItemsArrayRef } ], ['aurelia', 'ivan'] ); } { my $res = $handle->DeleteFromSelect( 'UsersToGroups' => 'SELECT id FROM UsersToGroups WHERE GroupId = ?', 1 ); is( $res, 2 ); my $users = TestApp::Users->new( $handle ); my $alias = $users->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); $users->Limit( ALIAS => $alias, FIELD => 'GroupId', VALUE => 1 ); is( $users->Count, 0 ); } { my $res = $handle->SimpleUpdateFromSelect( 'UsersToGroups', { UserId => 2, GroupId => 2 }, 'SELECT id FROM UsersToGroups WHERE UserId = ? AND GroupId = ?', 1, 3 ); is( $res, 1 ); my $u2gs = TestApp::UsersToGroups->new( $handle ); $u2gs->Limit( FIELD => 'UserId', VALUE => 1 ); $u2gs->Limit( FIELD => 'GroupId', VALUE => 3 ); is( $u2gs->Count, 0 ); $u2gs = TestApp::UsersToGroups->new( $handle ); $u2gs->Limit( FIELD => 'UserId', VALUE => 2 ); $u2gs->Limit( FIELD => 'GroupId', VALUE => 2 ); is( $u2gs->Count, 1 ); } diag "insert into table from the same table" if $ENV{'TEST_VERBOSE'}; { my $res = $handle->InsertFromSelect( 'UsersToGroups' => ['UserId', 'GroupId'], 'SELECT GroupId, UserId FROM UsersToGroups', ); is( $res, 2 ); } diag "insert into table from two tables" if $ENV{'TEST_VERBOSE'}; { TODO: { local $TODO; $TODO = "No idea how to make it work on Oracle" if $d eq 'Oracle'; my $res = do { local $handle->dbh->{'PrintError'} = 0; local $SIG{__WARN__} = sub {}; $handle->InsertFromSelect( 'UsersToGroups' => ['UserId', 'GroupId'], "SELECT u.id, g.id FROM Users u, $groups_table g WHERE u.Login LIKE ? AND g.Name = ?", '%a%', 'Support' ); }; is( $res, 2 ); my $users = TestApp::Users->new( $handle ); my $u2g_alias = $users->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); my $g_alias = $users->Join( ALIAS1 => $u2g_alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id', ); $users->Limit( ALIAS => $g_alias, FIELD => 'Name', VALUE => 'Support' ); is_deeply( [ sort map $_->Login, @{ $users->ItemsArrayRef } ], ['aurelia', 'ivan'] ); } } cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE TABLE Users ( id integer primary key, Login varchar(36) ) }, q{ CREATE TABLE UsersToGroups ( id integer primary key, UserId integer, GroupId integer ) }, q{ CREATE TABLE Groups ( id integer primary key, Name varchar(36) ) }, ] } # TEMPORARY tables can not be referenced more than once # in the same query, use real table for UsersToGroups sub schema_mysql { [ q{ CREATE TEMPORARY TABLE Users ( id integer primary key AUTO_INCREMENT, Login varchar(36) ) }, q{ CREATE TABLE UsersToGroups ( id integer primary key AUTO_INCREMENT, UserId integer, GroupId integer ) }, q{ CREATE TEMPORARY TABLE `Groups` ( id integer primary key AUTO_INCREMENT, Name varchar(36) ) }, ] } sub cleanup_schema_mysql { [ "DROP TABLE UsersToGroups", ] } sub schema_pg { [ q{ CREATE TEMPORARY TABLE Users ( id serial primary key, Login varchar(36) ) }, q{ CREATE TEMPORARY TABLE UsersToGroups ( id serial primary key, UserId integer, GroupId integer ) }, q{ CREATE TEMPORARY TABLE Groups ( id serial primary key, Name varchar(36) ) }, ] } sub schema_oracle { [ "CREATE SEQUENCE Users_seq", "CREATE TABLE Users ( id integer CONSTRAINT Users_Key PRIMARY KEY, Login varchar(36) )", "CREATE SEQUENCE UsersToGroups_seq", "CREATE TABLE UsersToGroups ( id integer CONSTRAINT UsersToGroups_Key PRIMARY KEY, UserId integer, GroupId integer )", "CREATE SEQUENCE Groups_seq", "CREATE TABLE Groups ( id integer CONSTRAINT Groups_Key PRIMARY KEY, Name varchar(36) )", ] } sub cleanup_schema_oracle { [ "DROP SEQUENCE Users_seq", "DROP TABLE Users", "DROP SEQUENCE Groups_seq", "DROP TABLE Groups", "DROP SEQUENCE UsersToGroups_seq", "DROP TABLE UsersToGroups", ] } package TestApp::Record; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->_Handle($handle); my $table = ref $self || $self; $table =~ s/.*:://; $table .= 's'; $self->Table( $table ); } package TestApp::Col; use base 'DBIx::SearchBuilder'; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); my $table = ref $self || $self; $table =~ s/.*:://; $self->Table( $table ); } sub NewItem { my $self = shift; my $record_class = (ref($self) || $self); $record_class =~ s/s$//; return $record_class->new( $self->_Handle ); } package TestApp::User; use base 'TestApp::Record'; sub _ClassAccessible { return { id => {read => 1, type => 'int(11)'}, Login => {read => 1, write => 1, type => 'varchar(36)'}, } } sub init_data { return ( [ 'Login' ], [ 'ivan' ], [ 'john' ], [ 'bob' ], [ 'aurelia' ], ); } package TestApp::Group; use base 'TestApp::Record'; sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, Name => {read => 1, write => 1, type => 'varchar(36)'}, } } sub init_data { return ( [ 'Name' ], [ 'Developers' ], [ 'Sales' ], [ 'Support' ], ); } package TestApp::UsersToGroup; use base 'TestApp::Record'; sub _ClassAccessible { return { id => {read => 1, type => 'int(11)'}, UserId => {read => 1, type => 'int(11)'}, GroupId => {read => 1, type => 'int(11)'}, } } sub init_data { return ([ 'GroupId', 'UserId' ]); } package TestApp::Users; use base 'TestApp::Col'; package TestApp::Groups; use base 'TestApp::Col'; package TestApp::UsersToGroups; use base 'TestApp::Col'; DBIx-SearchBuilder-1.71/t/testmodels.pl000644 000765 000024 00000001314 13275205765 020606 0ustar00sunnavystaff000000 000000 package Sample::Address; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: 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 $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub Table { "Employees" } sub Schema { return { Name => { TYPE => 'varchar', }, Dexterity => { TYPE => 'integer', }, } } 1;DBIx-SearchBuilder-1.71/t/00.load.t000644 000765 000024 00000001441 13275205765 017411 0ustar00sunnavystaff000000 000000 use Test::More tests => 12; BEGIN { use_ok("DBIx::SearchBuilder"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::Informix"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::mysql"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::mysqlPP"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::ODBC"); } BEGIN { SKIP: { skip "DBD::Oracle is not installed", 1 unless eval { require DBD::Oracle }; use_ok("DBIx::SearchBuilder::Handle::Oracle"); } } BEGIN { use_ok("DBIx::SearchBuilder::Handle::Pg"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::Sybase"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::SQLite"); } BEGIN { use_ok("DBIx::SearchBuilder::Record"); } BEGIN { use_ok("DBIx::SearchBuilder::Record::Cachable"); } DBIx-SearchBuilder-1.71/t/10schema.t000644 000765 000024 00000005535 14123431434 017650 0ustar00sunnavystaff000000 000000 #!/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, <new; isa_ok($employee, 'Sample::Employee'); $ret = $SG->AddModel($employee); ok($ret != 0, "added model from an instantiated object"); is_ignoring_space($SG->CreateTableSQLText, <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; } DBIx-SearchBuilder-1.71/t/03transactions.t000644 000765 000024 00000015122 14123431434 021113 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 52; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; 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 $handle = get_handle( $d ); isa_ok($handle, 'DBIx::SearchBuilder::Handle'); { # clear PrevHandle no warnings 'once'; $DBIx::SearchBuilder::Handle::PrevHandle = undef; } diag("disconnected handle") if $ENV{'TEST_VERBOSE'}; is($handle->TransactionDepth, undef, "undefined transaction depth"); is($handle->BeginTransaction, undef, "couldn't begin transaction"); is($handle->TransactionDepth, undef, "still undefined transaction depth"); ok($handle->EndTransaction(Action => 'commit', Force => 1), "force commit success silently"); ok($handle->Commit('force'), "force commit success silently"); ok($handle->EndTransaction(Action => 'rollback', Force => 1), "force rollback success silently"); ok($handle->Rollback('force'), "force rollback success silently"); # XXX: ForceRollback function should deprecated ok($handle->ForceRollback, "force rollback success silently"); { my $warn = 0; local $SIG{__WARN__} = sub{ $_[0] =~ /transaction with none in progress/? $warn++: warn @_ }; ok(!$handle->Rollback, "not forced rollback returns false"); is($warn, 1, "not forced rollback fires warning"); ok(!$handle->Commit, "not forced commit returns false"); is($warn, 2, "not forced commit fires warning"); } connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); diag("connected handle without transaction") if $ENV{'TEST_VERBOSE'}; is($handle->TransactionDepth, 0, "transaction depth is 0"); ok($handle->Commit('force'), "force commit success silently"); ok($handle->Rollback('force'), "force rollback success silently"); { my $warn = 0; local $SIG{__WARN__} = sub{ $_[0] =~ /transaction with none in progress/? $warn++: warn @_ }; ok(!$handle->Rollback, "not forced rollback returns false"); is($warn, 1, "not forced rollback fires warning"); ok(!$handle->Commit, "not forced commit returns false"); is($warn, 2, "not forced commit fires warning"); } diag("begin and commit empty transaction") if $ENV{'TEST_VERBOSE'}; ok($handle->BeginTransaction, "begin transaction"); is($handle->TransactionDepth, 1, "transaction depth is 1"); ok($handle->Commit, "commit successed"); is($handle->TransactionDepth, 0, "transaction depth is 0"); diag("begin and rollback empty transaction") if $ENV{'TEST_VERBOSE'}; ok($handle->BeginTransaction, "begin transaction"); is($handle->TransactionDepth, 1, "transaction depth is 1"); ok($handle->Rollback, "rollback successed"); is($handle->TransactionDepth, 0, "transaction depth is 0"); diag("nested empty transactions") if $ENV{'TEST_VERBOSE'}; ok($handle->BeginTransaction, "begin transaction"); is($handle->TransactionDepth, 1, "transaction depth is 1"); ok($handle->BeginTransaction, "begin nested transaction"); is($handle->TransactionDepth, 2, "transaction depth is 2"); ok($handle->Commit, "commit successed"); is($handle->TransactionDepth, 1, "transaction depth is 1"); ok($handle->Commit, "commit successed"); is($handle->TransactionDepth, 0, "transaction depth is 0"); diag("init schema in transaction and commit") if $ENV{'TEST_VERBOSE'}; # MySQL doesn't support transactions for CREATE TABLE # so it's fake transactions test ok($handle->BeginTransaction, "begin transaction"); is($handle->TransactionDepth, 1, "transaction depth is 1"); my $ret = init_schema( 'TestApp::Address', $handle ); isa_ok($ret, 'DBI::st', "Inserted the schema. got a statement handle back"); ok($handle->Commit, "commit successed"); is($handle->TransactionDepth, 0, "transaction depth is 0"); diag("nested txns with mixed escaping actions") if $ENV{'TEST_VERBOSE'}; ok($handle->BeginTransaction, "begin transaction"); ok($handle->BeginTransaction, "begin nested transaction"); ok($handle->Rollback, "rollback successed"); { my $warn = 0; local $SIG{__WARN__} = sub{ $_[0] =~ /Rollback and commit are mixed/? $warn++: warn @_ }; ok($handle->Commit, "commit successed"); is($warn, 1, "not forced rollback fires warning"); } ok($handle->BeginTransaction, "begin transaction"); ok($handle->BeginTransaction, "begin nested transaction"); ok($handle->Commit, "rollback successed"); { my $warn = 0; local $SIG{__WARN__} = sub{ $_[0] =~ /Rollback and commit are mixed/? $warn++: warn @_ }; ok($handle->Rollback, "commit successed"); is($warn, 1, "not forced rollback fires warning"); } cleanup_schema( 'TestApp::Address', $handle ); }} # SKIP, foreach blocks 1; package TestApp::Address; use base qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Address'); $self->_Handle($handle); } sub ValidateName { my ($self, $value) = @_; return 0 if $value =~ /invalid/i; return 1; } sub _ClassAccessible { { id => {read => 1, type => 'int(11)', default => ''}, Name => {read => 1, write => 1, type => 'varchar(14)', default => ''}, Phone => {read => 1, write => 1, type => 'varchar(18)', length => 18, default => ''}, EmployeeId => {read => 1, write => 1, type => 'int(8)', default => ''}, } } sub schema_mysql { < 18; 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_users = init_data( 'TestApp::User', $handle ); ok( $count_users, "init users data" ); my $count_groups = init_data( 'TestApp::Group', $handle ); ok( $count_groups, "init groups data" ); my $count_us2gs = init_data( 'TestApp::UsersToGroup', $handle ); ok( $count_us2gs, "init users&groups relations data" ); my $clean_obj = TestApp::Users->new( $handle ); diag "FUNCTION with ? in Limit" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->Limit( FUNCTION => 'SUBSTR(?, 1, 1)', FIELD => 'Login', VALUE => 'I' ); is( $users_obj->Count, 1, "only one value" ); is( $users_obj->First->Login, 'Ivan', "ivan is the only match" ); } diag "make sure case insensitive works" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->Limit( FUNCTION => 'SUBSTR(?, 1, 1)', FIELD => 'Login', VALUE => 'i' ); is( $users_obj->Count, 1, "only one value" ); is( $users_obj->First->Login, 'Ivan', "ivan is the only match" ); } diag "FUNCTION without ?, but with () in Limit" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->Limit( FUNCTION => 'SUBSTR(main.Login, 1, 1)', FIELD => 'Login', VALUE => 'I' ); is( $users_obj->Count, 1, "only one value" ); is( $users_obj->First->Login, 'Ivan', "ivan is the only match" ); } diag "FUNCTION with ? in Column" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->UnLimit; $users_obj->Column(FIELD => 'id'); my $alias = $users_obj->Column(FIELD => 'Login', FUNCTION => 'SUBSTR(?, 1, 1)'); is( $alias, 'Login' ); is_deeply( [sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [sort qw(a B I j)], 'correct values', ); } diag "FUNCTION without ?, but with () in Column" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->UnLimit; $users_obj->Column(FIELD => 'id'); my $alias = $users_obj->Column(FIELD => 'Login', FUNCTION => 'SUBSTR(main.Login, 1, 1)'); is( $alias, 'Login' ); is_deeply( [sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [sort qw(a B I j)], 'correct values', ); } diag "NULL FUNCTION in Column" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->UnLimit; $users_obj->Column(FIELD => 'id'); $users_obj->Column(FIELD => 'Login', FUNCTION => 'NULL'); is_deeply( [ map $_->Login, @{ $users_obj->ItemsArrayRef } ], [(undef)x4], 'correct values', ); } diag "FUNCTION w/0 ? and () in Column" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->UnLimit; my $u2g_alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId', ); $users_obj->GroupBy({FIELD => 'Login'}); $users_obj->Column(FIELD => 'Login'); my $column_alias = $users_obj->Column(FIELD => 'id', ALIAS => $u2g_alias, FUNCTION => 'COUNT'); isnt( $column_alias, 'id' ); is_deeply( { map { $_->Login => $_->_Value($column_alias) } @{ $users_obj->ItemsArrayRef } }, { Ivan => 2, john => 1, Bob => 0, aurelia => 1 }, 'correct values', ); } cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE TABLE Users ( id integer primary key, Login varchar(36) ) }, q{ CREATE TABLE UsersToGroups ( id integer primary key, UserId integer, GroupId integer ) }, q{ CREATE TABLE Groups ( id integer primary key, Name varchar(36) ) }, ] } sub schema_mysql { [ q{ CREATE TEMPORARY TABLE Users ( id integer primary key AUTO_INCREMENT, Login varchar(36) ) }, q{ CREATE TEMPORARY TABLE UsersToGroups ( id integer primary key AUTO_INCREMENT, UserId integer, GroupId integer ) }, q{ CREATE TEMPORARY TABLE `Groups` ( id integer primary key AUTO_INCREMENT, Name varchar(36) ) }, ] } sub schema_pg { [ q{ CREATE TEMPORARY TABLE Users ( id serial primary key, Login varchar(36) ) }, q{ CREATE TEMPORARY TABLE UsersToGroups ( id serial primary key, UserId integer, GroupId integer ) }, q{ CREATE TEMPORARY TABLE Groups ( id serial primary key, Name varchar(36) ) }, ] } sub schema_oracle { [ "CREATE SEQUENCE Users_seq", "CREATE TABLE Users ( id integer CONSTRAINT Users_Key PRIMARY KEY, Login varchar(36) )", "CREATE SEQUENCE UsersToGroups_seq", "CREATE TABLE UsersToGroups ( id integer CONSTRAINT UsersToGroups_Key PRIMARY KEY, UserId integer, GroupId integer )", "CREATE SEQUENCE Groups_seq", "CREATE TABLE Groups ( id integer CONSTRAINT Groups_Key PRIMARY KEY, Name varchar(36) )", ] } sub cleanup_schema_oracle { [ "DROP SEQUENCE Users_seq", "DROP TABLE Users", "DROP SEQUENCE Groups_seq", "DROP TABLE Groups", "DROP SEQUENCE UsersToGroups_seq", "DROP TABLE UsersToGroups", ] } package TestApp::User; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: 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(36)'}, } } sub init_data { return ( [ 'Login' ], [ 'Ivan' ], [ 'john' ], [ 'Bob' ], [ 'aurelia' ], ); } package TestApp::Users; 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; package TestApp::Group; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Groups'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, Name => {read => 1, write => 1, type => 'varchar(36)'}, } } sub init_data { return ( [ 'Name' ], [ 'Developers' ], [ 'Sales' ], [ 'Support' ], ); } package TestApp::Groups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); $self->Table('Groups'); } sub NewItem { return TestApp::Group->new( (shift)->_Handle ) } 1; package TestApp::UsersToGroup; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('UsersToGroups'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, UserId => {read => 1, type => 'int(11)'}, GroupId => {read => 1, type => 'int(11)'}, } } sub init_data { return ( [ 'GroupId', 'UserId' ], # dev group [ 1, 1 ], [ 1, 2 ], [ 1, 4 ], # sales # [ 2, 0 ], # support [ 3, 1 ], ); } package TestApp::UsersToGroups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->Table('UsersToGroups'); return $self->SUPER::_Init( Handle => shift ); } sub NewItem { return TestApp::UsersToGroup->new( (shift)->_Handle ) } 1; DBIx-SearchBuilder-1.71/t/02records_datetime.t000644 000765 000024 00000022022 14123431434 021714 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w BEGIN { $ENV{'TZ'} = 'Europe/Moscow' }; use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 38; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; my $handle; my $skip_tz_tests; 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; } $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); diag "testing $d" if $ENV{'TEST_VERBOSE'}; 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" ); is( $handle->DateTimeFunction, 'NULL', 'no type' ); is( $handle->DateTimeFunction( Type => 'bad function' ), 'NULL', 'bad type' ); is( $handle->ConvertTimezoneFunction( Field => '?' ), '?', 'no To argument' ); is( $handle->ConvertTimezoneFunction( To => 'utc', Field => '?' ), '?', 'From and To equal' ); $skip_tz_tests = 0; if ( $d eq 'SQLite' ) { my $check = '2013-04-01 16:00:00'; my ($got) = $handle->dbh->selectrow_array("SELECT datetime(?,'localtime')", undef, $check); $skip_tz_tests = 1 if $got eq $check; } elsif ($d eq 'mysql') { my $check = '2013-04-01 16:00:00'; my ($got) = $handle->dbh->selectrow_array( "SELECT CONVERT_TZ(?, ?, ?)", undef, $check, 'UTC', 'Europe/Moscow' ); $skip_tz_tests = 1 if !$got || $got eq $check; } foreach my $type ('date time', 'DateTime', 'date_time', 'Date-Time') { run_test( { Type => $type }, { '' => undef, '2011-05-20 19:53:23' => '2011-05-20 19:53:23', }, ); run_test( { Type => $type, Timezone => { To => 'Europe/Moscow' } }, { '' => undef, '2011-05-20 19:53:23' => '2011-05-20 23:53:23', '2011-05-20 22:53:23' => '2011-05-21 02:53:23', }, ); } run_test( { Type => 'time' }, { '' => undef, '2011-05-20 19:53:23' => '19:53:23', }, ); run_test( { Type => 'time', Timezone => { To => 'Europe/Moscow' } }, { '' => undef, '2011-05-20 19:53:23' => '23:53:23', '2011-05-20 22:53:23' => '2:53:23', }, ); run_test( { Type => 'hourly' }, { '' => undef, '2011-05-20 19:53:23' => '2011-05-20 19', '2011-05-20 22:53:23' => '2011-05-20 22', }, ); run_test( { Type => 'hourly', Timezone => { To => 'Europe/Moscow' } }, { '' => undef, '2011-05-20 19:53:23' => '2011-05-20 23', '2011-05-20 22:53:23' => '2011-05-21 02', }, ); run_test( { Type => 'hour' }, { '' => undef, '2011-05-20 19:53:23' => '19', }, ); run_test( { Type => 'hour', Timezone => { To => 'Europe/Moscow' } }, { '' => undef, '2011-05-20 19:53:23' => '23', '2011-05-20 22:53:23' => '2', }, ); foreach my $type ( 'date', 'daily' ) { run_test( { Type => $type }, { '' => undef, '2011-05-20 19:53:23' => '2011-05-20', }, ); run_test( { Type => $type, Timezone => { To => 'Europe/Moscow' } }, { '' => undef, '2011-05-20 19:53:23' => '2011-05-20', '2011-05-20 22:53:23' => '2011-05-21', }, ); } run_test( { Type => 'day of week' }, { '' => undef, '2011-05-20 19:53:23' => '5', '2011-05-21 19:53:23' => '6', '2011-05-22 19:53:23' => '0', '2011-05-20 22:53:23' => '5', '2011-05-21 22:53:23' => '6', '2011-05-22 22:53:23' => '0', }, ); run_test( { Type => 'day of week', Timezone => { To => 'Europe/Moscow' } }, { '' => undef, '2011-05-20 19:53:23' => '5', '2011-05-21 19:53:23' => '6', '2011-05-22 19:53:23' => '0', '2011-05-20 22:53:23' => '6', '2011-05-21 22:53:23' => '0', '2011-05-22 22:53:23' => '1', }, ); foreach my $type ( 'day', 'DayOfMonth' ) { run_test( { Type => $type }, { '' => undef, '2011-05-20 19:53:23' => '20', '2011-05-20 22:53:23' => '20', }, ); run_test( { Type => $type, Timezone => { To => 'Europe/Moscow' } }, { '' => undef, '2011-05-20 19:53:23' => '20', '2011-05-20 22:53:23' => '21', }, ); } run_test( { Type => 'day of year' }, { '' => undef, '2011-05-20 19:53:23' => '140', '2011-05-20 22:53:23' => '140', }, ); run_test( { Type => 'day of year', Timezone => { To => 'Europe/Moscow' } }, { '' => undef, '2011-05-20 19:53:23' => '140', '2011-05-20 22:53:23' => '141', }, ); run_test( { Type => 'month' }, { '' => undef, '2011-05-20 19:53:23' => 5, }, ); run_test( { Type => 'monthly' }, { '' => undef, '2011-05-20 19:53:23' => '2011-05', }, ); foreach my $type ( 'year', 'annually' ) { run_test( { Type => $type }, { '' => undef, '2011-05-20 19:53:23' => '2011', }, ); } run_test( { Type => 'week of year' }, { '' => undef, '2011-05-20 19:53:23' => '20', }, ); cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks sub run_test { my $props = shift; my $expected = shift; SKIP: { skip "skipping timezone tests", 1 if $props->{'Timezone'} && $skip_tz_tests; my $users = TestApp::Users->new( $handle ); $users->UnLimit; $users->Column( FIELD => 'Expires' ); my $column = $users->Column( ALIAS => 'main', FIELD => 'Expires', FUNCTION => $users->_Handle->DateTimeFunction( %$props ), ); my %got; while ( my $user = $users->Next ) { $got{ $user->Expires || '' } = $user->__Value( $column ); } foreach my $key ( keys %got ) { delete $got{ $key } unless exists $expected->{ $key }; $got{ $key } =~ s/^0+(?!$)// if defined $got{ $key }; } local $Test::Builder::Level = $Test::Builder::Level + 1; is_deeply( \%got, $expected, "correct ". $props->{'Type'} ." function" ) or diag "wrong SQL: ". $users->BuildSelectQuery; } } 1; package TestApp; sub schema_mysql { <Table('Users'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Expires => {read => 1, write => 1, type => 'datetime' }, } } sub init_data { return ( [ 'Expires' ], [ undef ], [ '2011-05-20 19:53:23' ], # friday [ '2011-05-21 19:53:23' ], # saturday [ '2011-05-22 19:53:23' ], # sunday [ '2011-05-20 22:53:23' ], # fri in UTC, sat in moscow [ '2011-05-21 22:53:23' ], # sat in UTC, sun in moscow [ '2011-05-22 22:53:23' ], # sun in UTC, mon in moscow ); } 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; DBIx-SearchBuilder-1.71/t/02searches_joins.t000644 000765 000024 00000034236 14123431434 021410 0ustar00sunnavystaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 59; 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_users = init_data( 'TestApp::User', $handle ); ok( $count_users, "init users data" ); my $count_groups = init_data( 'TestApp::Group', $handle ); ok( $count_groups, "init groups data" ); my $count_us2gs = init_data( 'TestApp::UsersToGroup', $handle ); ok( $count_us2gs, "init users&groups relations data" ); my $clean_obj = TestApp::Users->new( $handle ); my $users_obj = $clean_obj->Clone; is_deeply( $users_obj, $clean_obj, 'after Clone looks the same'); diag "inner JOIN with ->Join method" if $ENV{'TEST_VERBOSE'}; { ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); ok( $alias, "Join returns alias" ); TODO: { local $TODO = "is joined doesn't mean is limited, count returns 0"; is( $users_obj->Count, 3, "three users are members of the groups" ); } # fake limit to check if join actually joins $users_obj->Limit( FIELD => 'id', OPERATOR => 'IS NOT', VALUE => 'NULL' ); is( $users_obj->Count, 3, "three users are members of the groups" ); } diag "LEFT JOIN with ->Join method" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); ok( $alias, "Join returns alias" ); $users_obj->Limit( ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS', VALUE => 'NULL' ); ok( $users_obj->BuildSelectQuery =~ /LEFT JOIN/, 'LJ is not optimized away'); is( $users_obj->Count, 1, "user is not member of any group" ); is( $users_obj->First->id, 3, "correct user id" ); } diag "LEFT JOIN with IS NOT NULL on the right side" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); ok( $alias, "Join returns alias" ); $users_obj->Limit( ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS NOT', VALUE => 'NULL' ); ok( $users_obj->BuildSelectQuery !~ /LEFT JOIN/, 'LJ is optimized away'); is( $users_obj->Count, 3, "users whos is memebers of at least one group" ); } diag "LEFT JOIN with ->Join method and using alias" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->NewAlias( 'UsersToGroups' ); ok( $alias, "new alias" ); is($users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', ALIAS2 => $alias, FIELD2 => 'UserId' ), $alias, "joined table" ); $users_obj->Limit( ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS', VALUE => 'NULL' ); ok( $users_obj->BuildSelectQuery =~ /LEFT JOIN/, 'LJ is not optimized away'); is( $users_obj->Count, 1, "user is not member of any group" ); } diag "main <- alias <- join" if $ENV{'TEST_VERBOSE'}; { # The join depends on the alias, we should build joins with correct order. $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->NewAlias( 'UsersToGroups' ); ok( $alias, "new alias" ); ok( $users_obj->_isJoined, "object with aliases is joined"); $users_obj->Limit( FIELD => 'id', VALUE => "$alias.UserId", QUOTEVALUE => 0); ok( my $groups_alias = $users_obj->Join( ALIAS1 => $alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id', ), "joined table" ); $users_obj->Limit( ALIAS => $groups_alias, FIELD => 'Name', VALUE => 'Developers' ); is( $users_obj->Count, 3, "three members" ); } diag "main <- alias <- join into main" if $ENV{'TEST_VERBOSE'}; { # DBs' parsers don't like: FROM X, Y JOIN C ON C.f = X.f $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); ok( my $groups_alias = $users_obj->NewAlias( 'Groups' ), "new alias" ); ok( my $g2u_alias = $users_obj->Join( ALIAS1 => 'main', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId', ), "joined table" ); $users_obj->Limit( ALIAS => $g2u_alias, FIELD => 'GroupId', VALUE => "$groups_alias.id", QUOTEVALUE => 0); $users_obj->Limit( ALIAS => $groups_alias, FIELD => 'Name', VALUE => 'Developers' ); #diag $users_obj->BuildSelectQuery; is( $users_obj->Count, 3, "three members" ); } diag "cascaded LEFT JOIN optimization" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); ok( $alias, "Join returns alias" ); $alias = $users_obj->Join( TYPE => 'LEFT', ALIAS1 => $alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id' ); $users_obj->Limit( ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS NOT', VALUE => 'NULL' ); ok( $users_obj->BuildSelectQuery !~ /LEFT JOIN/, 'both LJs are optimized away'); is( $users_obj->Count, 3, "users whos is memebers of at least one group" ); } diag "LEFT JOIN optimization and OR clause" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); $users_obj->_OpenParen('my_clause'); $users_obj->Limit( SUBCLAUSE => 'my_clause', ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS NOT', VALUE => 'NULL' ); $users_obj->Limit( SUBCLAUSE => 'my_clause', ENTRY_AGGREGATOR => 'OR', FIELD => 'id', VALUE => 3 ); $users_obj->_CloseParen('my_clause'); ok( $users_obj->BuildSelectQuery =~ /LEFT JOIN/, 'LJ is not optimized away'); is( $users_obj->Count, 4, "all users" ); } diag "DISTINCT in Join" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId', DISTINCT => 1, ); $users_obj->Limit( ALIAS => $alias, FIELD => 'GroupId', VALUE => 1, ); ok( $users_obj->BuildSelectQuery !~ /DISTINCT|GROUP\s+BY/i, 'no distinct in SQL'); is_deeply( [ sort map $_->Login, @{$users_obj->ItemsArrayRef} ], [ 'aurelia', 'ivan', 'john' ], "members of dev group" ); } diag "DISTINCT in NewAlias" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->NewAlias('UsersToGroups', DISTINCT => 1); $users_obj->Join( FIELD1 => 'id', ALIAS2 => $alias, FIELD2 => 'UserId', ); $users_obj->Limit( ALIAS => $alias, FIELD => 'GroupId', VALUE => 1, ); ok( $users_obj->BuildSelectQuery !~ /DISTINCT|GROUP\s+BY/i, 'no distinct in SQL'); is_deeply( [ sort map $_->Login, @{$users_obj->ItemsArrayRef} ], [ 'aurelia', 'ivan', 'john' ], "members of dev group" ); } diag "mixing DISTINCT" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $u2g_alias = $users_obj->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId', DISTINCT => 0, ); my $g_alias = $users_obj->Join( ALIAS1 => $u2g_alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id', DISTINCT => 1, ); $users_obj->Limit( ALIAS => $g_alias, FIELD => 'Name', VALUE => 'Developers', ); $users_obj->Limit( ALIAS => $g_alias, FIELD => 'Name', VALUE => 'Sales', ); ok( $users_obj->BuildSelectQuery =~ /DISTINCT|GROUP\s+BY/i, 'distinct in SQL'); is_deeply( [ sort map $_->Login, @{$users_obj->ItemsArrayRef} ], [ 'aurelia', 'ivan', 'john' ], "members of dev group" ); } cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE TABLE Users ( id integer primary key, Login varchar(36) ) }, q{ CREATE TABLE UsersToGroups ( id integer primary key, UserId integer, GroupId integer ) }, q{ CREATE TABLE Groups ( id integer primary key, Name varchar(36) ) }, ] } sub schema_mysql { [ q{ CREATE TEMPORARY TABLE Users ( id integer primary key AUTO_INCREMENT, Login varchar(36) ) }, q{ CREATE TEMPORARY TABLE UsersToGroups ( id integer primary key AUTO_INCREMENT, UserId integer, GroupId integer ) }, q{ CREATE TEMPORARY TABLE `Groups` ( id integer primary key AUTO_INCREMENT, Name varchar(36) ) }, ] } sub schema_pg { [ q{ CREATE TEMPORARY TABLE Users ( id serial primary key, Login varchar(36) ) }, q{ CREATE TEMPORARY TABLE UsersToGroups ( id serial primary key, UserId integer, GroupId integer ) }, q{ CREATE TEMPORARY TABLE Groups ( id serial primary key, Name varchar(36) ) }, ] } sub schema_oracle { [ "CREATE SEQUENCE Users_seq", "CREATE TABLE Users ( id integer CONSTRAINT Users_Key PRIMARY KEY, Login varchar(36) )", "CREATE SEQUENCE UsersToGroups_seq", "CREATE TABLE UsersToGroups ( id integer CONSTRAINT UsersToGroups_Key PRIMARY KEY, UserId integer, GroupId integer )", "CREATE SEQUENCE Groups_seq", "CREATE TABLE Groups ( id integer CONSTRAINT Groups_Key PRIMARY KEY, Name varchar(36) )", ] } sub cleanup_schema_oracle { [ "DROP SEQUENCE Users_seq", "DROP TABLE Users", "DROP SEQUENCE Groups_seq", "DROP TABLE Groups", "DROP SEQUENCE UsersToGroups_seq", "DROP TABLE UsersToGroups", ] } package TestApp::User; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: 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(36)'}, } } sub init_data { return ( [ 'Login' ], [ 'ivan' ], [ 'john' ], [ 'bob' ], [ 'aurelia' ], ); } package TestApp::Users; 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; package TestApp::Group; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Groups'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, Name => {read => 1, write => 1, type => 'varchar(36)'}, } } sub init_data { return ( [ 'Name' ], [ 'Developers' ], [ 'Sales' ], [ 'Support' ], ); } package TestApp::Groups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); $self->Table('Groups'); } sub NewItem { return TestApp::Group->new( (shift)->_Handle ) } 1; package TestApp::UsersToGroup; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('UsersToGroups'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, UserId => {read => 1, type => 'int(11)'}, GroupId => {read => 1, type => 'int(11)'}, } } sub init_data { return ( [ 'GroupId', 'UserId' ], # dev group [ 1, 1 ], [ 1, 2 ], [ 1, 4 ], # sales # [ 2, 0 ], # support [ 3, 1 ], ); } package TestApp::UsersToGroups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->Table('UsersToGroups'); return $self->SUPER::_Init( Handle => shift ); } sub NewItem { return TestApp::UsersToGroup->new( (shift)->_Handle ) } 1; DBIx-SearchBuilder-1.71/ex/Example/000755 000765 000024 00000000000 14123431630 017614 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/ex/create_tables.pl000644 000765 000024 00000003231 13275205765 021371 0ustar00sunnavystaff000000 000000 #!/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 < $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; DBIx-SearchBuilder-1.71/ex/Example/Model/000755 000765 000024 00000000000 14123431630 020654 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/ex/Example/Model/Address.pm000644 000765 000024 00000000535 13275205765 022621 0ustar00sunnavystaff000000 000000 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;DBIx-SearchBuilder-1.71/ex/Example/Model/Employee.pm000644 000765 000024 00000000337 13275205765 023013 0ustar00sunnavystaff000000 000000 package Example::Model::Employee; use base qw/DBIx::SearchBuilder::Record/; sub Table { "Employees" } sub Schema { return { Name => { TYPE => 'varchar', }, Dexterity => { TYPE => 'integer', }, } } 1;DBIx-SearchBuilder-1.71/inc/Module/000755 000765 000024 00000000000 14123431630 017603 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/inc/Module/Install/000755 000765 000024 00000000000 14123431630 021211 5ustar00sunnavystaff000000 000000 DBIx-SearchBuilder-1.71/inc/Module/AutoInstall.pm000644 000765 000024 00000062311 14123431566 022413 0ustar00sunnavystaff000000 000000 #line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.19'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::getcwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::getcwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1197 DBIx-SearchBuilder-1.71/inc/Module/Install.pm000644 000765 000024 00000027145 14123431566 021570 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.19'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( {no_chdir => 1, wanted => sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($File::Find::name); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }}, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. DBIx-SearchBuilder-1.71/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 14123431566 022621 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; DBIx-SearchBuilder-1.71/inc/Module/Install/Metadata.pm000644 000765 000024 00000043302 14123431566 023301 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; DBIx-SearchBuilder-1.71/inc/Module/Install/AutoInstall.pm000644 000765 000024 00000004162 14123431566 024021 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } 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}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; DBIx-SearchBuilder-1.71/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 14123431566 022461 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; DBIx-SearchBuilder-1.71/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 14123431566 023312 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; DBIx-SearchBuilder-1.71/inc/Module/Install/Can.pm000644 000765 000024 00000006405 14123431566 022265 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 245 DBIx-SearchBuilder-1.71/inc/Module/Install/Include.pm000644 000765 000024 00000001015 14123431566 023137 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; DBIx-SearchBuilder-1.71/inc/Module/Install/Makefile.pm000644 000765 000024 00000027437 14123431566 023311 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 DBIx-SearchBuilder-1.71/inc/Module/Install/Base.pm000644 000765 000024 00000002147 14123431566 022435 0ustar00sunnavystaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.19'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159