Jifty-DBI-0.77/0000755000175000017500000000000012246675115012151 5ustar chmrrchmrrJifty-DBI-0.77/Changes0000644000175000017500000013073512246674707013463 0ustar chmrrchmrrRevision history for Perl extension Jifty::DBI. 0.77 2013-12-01 * Fix for perl 5.19.4 parsing of @{ foo { ... } } * Fix signature 0.76 2013-06-17 * Provide source repository info in metadata * Default Cached::Memcached dependency off on Windows due to known build problems Thanks to Alexandr Ciornii for both. 0.75 2013-01-29 - Bug fixes: * backport a sort order fix for Pg handles from Searchbuilder * Work around Pg's sub-second formatting and DateTime::Parser::ISO8601 * Don't attempt to filter, eq-check, validate, or otherwise munge functions - Tests: * Fix failures on 5.17.6, reported as [rt.cpan.org #82978] * Update test to account for the ported bug fix in f9439a0 - Cleanup: * remove a useless wrapper function - Documentation: * SPROUT points out that the second fix in 0.73 is actually a run-time error, of course 0.74 2012-01-25 - Documentation: * Re-release of 0.73, now with a proper changelog 0.73 2012-01-25 - Fixes: * Allow prefetching of only a subset of the other table's columns (Alex Vandiver) * Avoid a run-time failure on blead caused by incorrect precedence (Thomas Sibley) 0.72 2011-10-17 - Fixes: * Handle DBH connection errors, retry the query (Luke Closs) - Documentation: * Mention old_value in after_* hooks (Thomas Sibley) 0.71 2011-06-17 - Fixes: * Ensure canonicalization and validation triggers are properly found (Thomas Sibley) 0.70 2011-06-15 - Fixes: * Respect manual column sort_orders (Thomas Sibley) * Produce more useful error messages during schema upgrades (Thomas Sibley) - Documentation: * Clarify what value after_set_* hooks receive (Thomas Sibley) 0.69 2011-05-17 - Fixes: * Remove some instances of qw() as parentheses deprecated in 5.14 (sunnavy) 0.68 2011-04-14 - Security: * Prevent SQL injection in column names, operators, order and group by (Alex Vandiver) * Fix distinct_query to catch injection and correctly rewrite to function => '' (Alex Vandiver) * Prevent SQL injection via IS - Fixes: * There is no need to check $args{column} around our LIKE adjustments (Alex Vandiver) * Slightly unify nigh-identical codepaths between Pg and Oracle (Alex Vandiver) 0.67 2011-02-28 - Features: * Make ->distinct_column_values use ->simple_query, thus going through our SQL logging infrastructure (Alex Vandiver) - Fixes: * Set raw_values in load_by_hash so the __raw_value method works when the record is loaded by a collection (Thomas Sibley) - Tests: * Author tests for no tabs (Shawn M Moore) 0.66 2011-02-14 - Features: * Provide a sane way to wrap a function around an aliased column in order_by * Pass old_value to triggers on column update - Fixes: * Respect the 'by' attribute for refers_to columns in create and set * Use the right FK when using a record object in load_by_cols or limit [rt.cpan.org #64779] * Don't encode fields when attempting to limit with IS * Fix since/till by refactoring columns to use an updated all_columns - Installation: * Only run these URI filter tests if we have URI [rt.cpan.org #65047] 0.64 Wed Dec 8 15:21:17 EST 2010 - Installation: * Minor distribution fixes 0.63 Wed Dec 8 15:14:17 EST 2010 - Features: * distinct_column_values method, docs and tests - Fixes: * Warn about load(arg => value) * Include column_name in the value passed to reader warning * It is a rare but possible case that 0 is a valid id * Ensure encode_base64 doesn't choke on utf8 0.62 Thu May 20 13:58:53 EST 2010 - Features: * Computed columns let you have the Jifty-DBI scaffolding but without touching the database * Column->is_boolean - Fixes: * Don't attempt to store undef values in memcached * Avoid undef warnings 0.61 Mon Jan 4 13:04:20 EST 2010 - Installation: * Minor distribution fixes 0.60 Mon Jan 4 13:02:17 EST 2010 - Features: * Allow passing of extra parameters to canonicalizers * Add an attribute which controls placeholder use for load_by_cols - Fixes: * Don't add LOWER() on <= or >= operators, only = and != * Better case sensitivity tests * Expose quote_value() on Jifty::DBI::Handle * When generating COUT, don't add a DISTINCT unless needed * Fix t/12prefetch.t's assumptions on row ordering 0.59 Wed Nov 18 20:12:57 EST 2009 - Features: * Support a special value of "all" in set_page_info - Fixes: * Make "default is ''" propagate correctly to ALTER and CREATE TABLE statements - Installation: * Our Module::Install was hilariously out of date 0.58 Tue Jul 14 03:21:21 EST 2009 - Possible incompatibilities: * Modules which use Jifty::DBI::Schema will have strict and warnings automatically applied to them. - Features: * Jifty::DBI::Handle now has methods for supported_drivers, available_drivers, and is_available_driver. - Fixes: * Remove unused _limit_clause method * Various error message improvements * Use ->new_item instead of ->record_class->new since it was a performance hit in Jifty * Avoid cals to ->new_item where possible - Documentation: * Document connect's quirky return value 0.57 Tue May 19 08:02:03 EDT 2009 - Major bugfixes: * Use eval {} in Jifty::DBI::Handle's DESTROY block when manipulating DBI Alterations to the DBI object in the DESTROY block must be wrapped in an eval {}, as object destruction order is not guaranteed during global destruction, and this interacts poorly with DBI's tie'd object. * During DESTROY, don't explicitly disconnect a dbh set InactiveDestroy The InactiveDestroy flag on DBI objects prevent them from being implicitly disconnected when they go out of scope -- for example, in the case where a process has forked, and two processes hold the socket open. However, it does not prevent them from being _explicitly_ disconnected, as we were doing in Jifty::DBI::Handle's DESTROY method. This caused InactiveDestroy to never kick in, causing either a shared socket, or two closed handles after a fork. We prevent this by having Jifty::DBI::Handle respect InactiveDestroy in its DESTROY method. * Do not use Scalar::Defer defaults for columns' defaults in the db - New features: * Add a display_length attribute on columns * add schema manipulation tables: rename_column and rename_table * If a column's default is a record, call its id method - Fixes: * Improve SQL error message and avoid its duplication * Pull the input_ and output_filters out of the instance hash - Tests: * Added a unit test for the SaltHash filter * use drop_table_if_exists in tests * add drop_table_if_exists in t/utils.t * unconditionaly drop tables for testing * test rename_table * add tests for rename_column * SaltHash test does not need an is_deeply() * Don't explicitly disconnect the handle, DESTROY handles it better * Test for warnings instead of letting them leak into the test output 0.53 Wed Mar 25 15:27:03 EDT 2009 - Major bugfixes: * On rollback, flush the record cache. This fixes a bug when SQLite reuses primary keys after rollback, and thus the record cache is wrong. * Apply filters to "default is ..." values, so "is boolean, default is 0" works on postgres, for instance * $self->_new_collection_args is passed to the ->new constructor of a collection, not its ->new_item method - Performance fixes: * Don't call accessor twice when we have values around * Don't create temporary variables we don't need around, just return * Optimize for the case when there are no output filters * Play with self/class only when passed argument is not a reference * In _do_search, separate prefetch and non-prefetch paths; the latter is a much tighter loop * Refactor first pass over results in prefetch path * Move a ->new_item call where we only need it * Jifty::DBI::Handle::SQLite - LOWER() in SQLite is expensive; it's easier just put COLLATE NOCASE on the column side. Bump DBD::SQLite to 1.14 which gives us COLLATE NOCASE. * Cache on record table, not record class so subclasses also get cached correctly. If the data in the underlying table changes, regardless of the class you're using, you want to load the new data. * Refactor _qualified_record_columns * call ->table for defaulting only when we actually want defaulting * Selay some method calls when possible in limit * Minor refactoring of _get_alias * grep before looping to loop over fewer values in load_from_hash * Cache load attempts in new_item in a local static cache * Cache filter class load attempts in _apply_filters * Save some slow Class::Accessor calls in Jifty::DBI::Filter * Stick aliases into COLUMNS as well, for faster lookup * Provide a faster load_from_hash for when we're being called from do_search - Datetime fixes: * _formatter is *inheritable* class data. If it happens to get set by the DateTime filter before getting set by one of its subclasses (the Date and Time filters), than it is stuck on the DateTime _formatter setting because the subclasses don't override it. There are a couple solutions, the simplest being to check the value of _strptime and update/override _formatter if it is different, which is what I've done here. (This may not be the most optimized solution.) * Require Time::Duration::Parse 0.06 to win us decimal durations like 1.5h * Fix a broken regex that just happened to work because we only fed it correct data * Add date_only method in date and datetime filters * For date-only timestamps, set hour, minute, and second to zero * Include the datetime string we're trying to decode in parse failure cluck * Use DateTime's strptime since we don't want additional logic - Documentation fixes: * Minor POD improvement for debian lintian in Jifty::DBI::Column * Adding an example of open_paren/close_paren and limit subclause. * Added documentation for "IS" on limit(). * Additional docs for load_by_cols * Update record_class' docs - Minor bugfixes: * Perltidy, primarily for indentation fixes * Update copyright year to 2009 * collections can now clear_order_by * requires('perl' => '5.8.3') confuses M:I. the "correct" incantation is perl_version('5.8.3') * Add the ability to unload columns and prefetched values * Use $args{'collection'}->limit instead of $self->Jifty::DBI::Collection::limit so we don't break * We accept IN or = as operators for array ref. values, so match against that (and do it case insensitively to boot) * Allow validators to get extra arguments * Storable with non-bytea is OK if we base64 * add double naming schema for record references, using name, name_by * fixed situation with 'column X_not_id refers_to M by "not_id"' * Aliases should be virtual * When we have group_by, the first column may not be enough to distinctify the rows. But since they're grouped, they're all distinct by definition. * turn _handle _is_limited rows_per_page into accessors * Clean out fetched when we load_from_hash * Pass arguments database_Version to the super method * Don't chomp Collection or s if prev character is ':', die instead, it can happen for annon collections based either on JDBI::Collection or J::Collection * No need to setup the pager, its constructor does that for us; actually it's really questionable that we need to setup pager when there is no paging by default * Don't optimize left joins on mysql 5.0 and newer, may be other DBs can drop this too * $caller->COLUMNS should not contain virtual methods from plugins * Add "raw value" internal values * Plugin import must not call ->columns which causes incorrect caching. 0.49 Mon Apr 07 22:16:48 EST 2008 - Major changes: * "is boolean" support for cross-database booleans * New filters: Duration, URI * column attribute encode_select for filtering columns on load_by_cols, etc * <$collection> and @$collection support * Protected and private fields, for Jifty's automatic action introspection * ping/reconnect on error * Memory leak, unnecessary query, and transaction fixes - All changes: * call _init_hander for all columns * Revert paging fix which isn't quite ready yet * Note that booleans render as checkboxes * Fixes for NULL boolean columns * Booleans get canonicalizers, so perl-level gets canonical values, not just the DB. * Canonicalization fixes * Catch some expected warnings with (new dependency on) Test::Warn * Get rid of an unbalanced vim-fold * Jifty::DBI::Filter::URI * Rename decode_select to encode_on_select * Fix final test failure: toggle pg_bool_tf before making the query * encode and decode were swapped :| * Some test fixes. DBD::Pg has a damn "DWIM" option for booleans that caused failures * Move the alias and column handling in ->limit up sooner so we have a column object as soon as possible * Apply filters on default values for attributes * Rename encode_select to decode_select (I always get the two confused) * Force undefined boolean attributes to be false, for sanity reasons * Add a new column attribute, encode_select. This will apply filters on load_by_cols and limit. Have Boolean use encode_select. * Complain if the encoded/decoded value doesn't return one of _is_true or _is_false. * Add "is boolean" support for not-braindead booleans. * Have filters receive the database handle * fixing our lower() behaviour on non-text columns when we were being stupid * better passing in the class of a joined table when using ->new_alias * defaulting to a not-null string * Quiet down defaults for an annoying regex match in current DBIx::DBSChema * Return self, not true, in boolean context * Fix collections in bool context * Pass all data to logging hook so they can do more interesting things with them immediately * micro-optimization of _filters which is called quite often * Add <$collection> and @$collection syntax sugar that simply calls $collection->next and $collection->items_array_ref behind the scenes. * Tiny POD tweak so t/pod-coverage.t passes. * Jifty::DBI::Handle - When "begin_transaction", "commit" and "rollback" did not succeed, the internal $TRANSDEPTH should be left unchanged. (Otherwise, a failed ->commit will cause future transactions to never really take place.) * Add a documentation meta-attribute, for Jifty * Debian packaging for 0.48 * Bump for added properties * Protected and private fields, for Jifty's automatic action introspection * Added the ping/reconnect on error as suggested by Jesse. * Fix typo * Upgrade dep to 0.05 now that the hh:mm(:ss) parsing code is in it * Better error checking * No need to duplicate order_by's logic, just call thrash explicitly and call add_order_by * Add Collection->add_order_by, which refines ordering, instead of thrashing it * Get rid of reference to deprecated method * Don't try to encode/decode empty values * Handle hh:mm(:ss)? within other duration strings so that "1d 2:30" works * More tests for the duration filter (to test different input formats and check the raw DB value) * Fix version * Handle hh:mm:ss in the duration filter as input and output a more concise format * dd missing dependancies with Class::Trigger in debian packaging for use of alone package libjifty-dbi-perl * Add optional dependencies on Time::Duration(::Parse) in Makefile.PL * Add a duration filter which uses Time::Duration and Time::Duration::Parse. Stores durations as seconds in the database and converts them to English strings for output. * Revert mistaken change * UNIVERSAL::require has a memory leak, fixed by 0.11 * Allow starts_with and ends_with in addition to STARTSWITH and ENDSWITH * We were leaking the collection on set_page_info. Yuck! We need some way to find these Scalar::Defer leaks * Be more careful about initializing values we're using * Fix a mismerge in 4642 * By not reaching inside the pager object, we save on some useless forced SQL queries * Be a bit cleverer about not always doing a count before doing a select (The previous behaviour was pathalogical) 0.48 Thu Nov 29 16:28:11 EST 2007 * User and password values are excluded from the DSN in a more proper fashion * Setting a default for RECORD_MIXINS and altering the mk_classdata() decls to avoid any confusion with the mk_accessors() interface. * Eliminated the ?: at the end of import() since RECORD_MIXINS is now [] by default. * Let users run arbitrary code during SQL statement logging * Exclude user and passowrd from the DSN so it doesn't show up in the terminal * use YAML () -> require YAML to suppress error when YAML is not installed (but ::Syck is installed) * Fix reverse joins. Broken in multiple ways. * added 'escape' option (undef by default) to Collection->limit, to allow " * where column like 'something including wildcard(\\%)' ESCAPE '\\'" kind of stuff, mainly for SQLite which doesn't seem to be able to escape wildcards without ESCAPE * changed escape character in the t/01searches.t from backslashes to at mar * k, which is cleaner and kind to postgres; added pod * typo fix in docs * mysql doesn't handle bare varchar's * TODO a test that needs us to force mysql to be case sensitive * expand the escape documentation * manifest skip pm_to_blib, add new test file to manifest * Update Changes 0.47 Fri Nov 16 15:23:28 EST 2007 or, "The chmrr fixfest" * Note for posterity why we can't apply acl checks to refers_to columns * The formatter can't be decided at compile time, because subclasses may override the format. Hence, make it once and cache it. * r4425 actually changed the way that undef foreign objects were treated; revert to the old behavior, but make it easier to achieve the new (aka Jifty's) behavior. * Only create the parser and formatter for DateTime objects once, as they are slow to create. * When looking up the column object in a limit, try to find the right class in the aliases. This only currently works if you specified the model class as the 'table2' in the join, instead of its table name. * Can now call ->record_class as a class method * Force chained auto-joins to be marked distinct * Alias columns now count as virtual * some tests for referencing. * Factor out ->_new_record_args and ->_new_collection_args on both Record and Collection; makes for easier subclassing in Jifty * (re-)wrapped POD * Remove broken ->_normal_join * $collection->prefetch is now smarter, stealing code from future tisql branch * $collection->_preload_columns becomes ->query_columns, to have a better name * $collection->{aliases} rolled into ->{joins}, to also not lie * $collection->{leftjoins} becomes ->{joins}, to not lie * Standardize on "prefetch" not "preload" * Fix preload for records * Don't grovel theough columns to find possible joins, just look at the joins * derived collections can't be relimited * add derived => 1 for prefetched collections * Remove Jifty::DBI::Collection->preload_columns, which was old and unused * '$sb' -> '$collection' because we aren't SearchBuilder anymore * perltidy * Get rid of a spurious warning * Whoops, turned off the wrong warning * POD coverage 0.46 Wed Nov 7 12:24:08 EST 2007 - POD Coverage nit - Fix for a stray tempfiles bug reported by ANDK 0.45 Add a warning for mandatory+till until we fix it Fix the mandatory/inactive tests We don't need to check that a column is mandatory if it's not active Add failing tests for mandatory columns that aren't active, they shouldn't have the not null constraint Bump to 0.45 because of the JDBI::Filter::DateTime functionality fixes Improve the decode doc, which was mostly just a copy of encode More needless warnings gone Better error message when trying to use load_by_cols on a column that doesn't exist Two fixes for timezones: Coerce input and output to be UTC (or Floating, if JDBI::Filter::Date) I think we were depending on DT:F:Strptime being saner than it is Use set_time_zone, not time_zone which is only a getter defined is not what you check to see if there is a hash entry. this will stop bogus extra sql calls that slowed down your app Allow the specification of functions as 'column' on sql search criteria. When we fail to load a related model class for a good reason, actually die, rather than burying the error mysql doesn't handle bare varchar's TODO a test that needs us to force mysql to be case sensitive typo fix in docs We can have 0-valued columns, again New column attribute: is case_sensitive Make load_by_cols respect column case sensitivity. NOTE this is a behaviour change as columns are by default case-insensitive, and the call was doing a case sensitive search, which is different from Collection searching. To make Jifty::DBI load_by_cols work in the old behaviour: Use $rec->load_by_cols( name => { value => 'foobar', case_sensitive => 0, operator => '=' }); unreadable and immutable are now in attributes. Refactor Jifty::DBI::Column to split attributes into two groups. Actual column-related (in jifty::dbi layer) ones, such as type, remains as accesssors. The rest goes into the attributes hash. This allows us to declare higher level meta data without having to change Jifty::DBI::Column in the future. Note that if you are accessing the column object's ->{label} directly this will now fail. Use ->label instead. *Test updates for case issues * Add support for non-lowercase column names Make sure limit() does not modify arrays passed in to the "value" parameter. * Allow is_distinct when joining collections, hinting the resulting collection is still distinct. * If table2 is given as a Jifty::DBI::Collection object, detect if the join is still distinct. Added documentation for using @EXPORT with mixins. Fix the call to the after_set trigger. Added a new accessor, RECORD_MIXINS, for tracking which mixins have been attached to a model. Adding basic documentation for before_set and after_set triggers. Adding before_set and after_set triggers and tests for them. Moved Jifty::DBI to use Class::Trigger instead of its own fork of Class::Trigger. Added tests and debugged register_triggers_for_column on record plugins. Improvements to the trigger documentation for after_create and before_create. Fix the documentation of the after_create trigger to match the actual behavior (and only that, this time). Removed register_triggers_late() in favor of register_triggers_for_column(), which is nearly the same thing but with clearer semantics. Updated documentation to discuss the register_triggers_late() method. 0.43 Fri Aug 24 00:13:20 EDT 2007 ---------------------------------------------------------------------- r66529 (orig r3939): audreyt | 2007-08-22 12:38:23 -0400 * Jifty::DBI::Filter::DateTime: The _time_zone setting was not honoured by ->decode, because the code had a no-op $dt->time_zone($tz) where it should've been $dt->set_time_zone($tz). ---------------------------------------------------------------------- r66518 (orig r3928): falcone | 2007-08-21 19:09:22 -0400 r23979@ketch: falcone | 2007-08-21 18:00:57 -0400 * tell Pg to be case sensitive on IN clauses and handle the arrayref structure used by IN ---------------------------------------------------------------------- r66517 (orig r3927): falcone | 2007-08-21 19:08:59 -0400 r23978@ketch: falcone | 2007-08-21 18:00:27 -0400 * we don't need to TODO this MySQL test because the case matches exactly and returns values ---------------------------------------------------------------------- r66197 (orig r3926): yves | 2007-08-21 10:49:01 -0400 debian packaging ---------------------------------------------------------------------- r66169 (orig r3923): efunneko | 2007-08-20 16:57:43 -0400 Added support for the IN operator within limits. This should be accompanied by an array ref of values to be compared against. It also allows an array ref to be passed with the '=' operator to accomplish the same thing ---------------------------------------------------------------------- r66164 (orig r3918): sterling | 2007-08-20 15:56:18 -0400 Fixing the name of the branch. ---------------------------------------------------------------------- r66163 (orig r3917): sterling | 2007-08-20 15:54:42 -0400 Creating a new branch to develop improvements on indexes and relationships. ---------------------------------------------------------------------- r66157 (orig r3911): trs | 2007-08-16 15:59:16 -0400 r26169@zot: tom | 2007-08-16 15:58:56 -0400 Backup r3908 for now since it breaks existing code ---------------------------------------------------------------------- r66154 (orig r3908): sterling | 2007-08-16 10:02:48 -0400 r8684@dynpc145: andrew | 2007-08-16 08:55:32 -0500 Added support for virtual record columns. ---------------------------------------------------------------------- r66153 (orig r3907): sterling | 2007-08-16 10:02:26 -0400 r8682@dynpc145: andrew | 2007-08-15 11:17:32 -0500 Added more code comments, minor perl tidy, and removed a redundant call to set the column type. ---------------------------------------------------------------------- r65006 (orig r3743): falcone | 2007-07-31 16:26:13 -0400 r23202@ketch: falcone | 2007-07-31 16:25:03 -0400 * we have code that uses Jifty::Collection::implicit_clauses and expects that where clause to still show up on an unlimit. This is wrong, but we need to sort out the "right" thing to do. ---------------------------------------------------------------------- r64931 (orig r3741): jesse | 2007-07-30 20:27:30 -0400 r64930@pinglin: jesse | 2007-07-30 20:27:14 -0400 * Removed this. not time yet ---------------------------------------------------------------------- r64929 (orig r3740): jesse | 2007-07-30 19:55:14 -0400 r64923@pinglin: jesse | 2007-07-30 19:54:31 -0400 * first stab at a UUID filter ---------------------------------------------------------------------- r64902 (orig r3729): jesse | 2007-07-28 20:27:31 -0400 r64901@pinglin: jesse | 2007-07-28 18:29:15 -0500 * Added a find_all_rows method which works like 'unlimit' without the side effect of calling _clean_slate and zapping other metadata. * Clarified unlimit's somewhat brutal nature. - Thanks to Mikko Lipasti ---------------------------------------------------------------------- r60774 (orig r3694): sartak | 2007-07-16 12:49:13 -0400 Fix 'uninitialized value' warnings ---------------------------------------------------------------------- r60655 (orig r3692): jesse | 2007-07-14 00:06:17 -0400 r60634@pinglin: jesse | 2007-07-13 20:14:44 -0400 * Additional bulletproofing to stop jifty from trying to insert a bogus date into the database. ---------------------------------------------------------------------- r60350 (orig r3644): trs | 2007-07-10 01:32:48 -0400 r25085@zot: tom | 2007-07-10 01:32:08 -0400 Fix type for Pg 0.41 Mon Apr 16 16:16:12 EDT 2007 * Fixed a broken dependency. Thanks to SAPER 0.40 Sun Apr 15 11:19:45 EDT 2007 * Added sample code to POD for 'before_create' and 'after_create' to make it easier for users to implement by copy and pasting. -evdb * Better non-lower()ing of non-string types on search. -jesse * Fix up and add POD so that POD coverage tests pass -trs * Kill unused JiftyRecord filter -trs * Fixed documentation coverage for Jifty::DBI::Handle::Informix. -sterling * Commented out incomplete apply_limits method in the Sybase handle. -sterling * Fixed documentation coverage in Jifty::DBI::Record::Cachable. -sterling * Fixed documentation coverage for Jifty::DBI::Record::Memcached. -sterling * Added pod-coverage.t to encourage better documentation. Added documentation to Jifty::DBI::Record::Plugin. -sterling * Added better handling of schema versioning -sterling * Added _init_methods_for_columns to explicitly handle accessor/mutator creation for all columns attached to a record -sterling * Applications employing JDBI can specify schema_version() in a sub-class of record to add better handling of "since" and "till" in both schema and code generation -sterling * Modified columns() on records to only return active columns -sterling * Added all_columns() to retrieve all columns on a record, even inactive ones -sterling * Added the active() method to columns to test to see if a column is active for the current schema version -sterling * Jifty::DBI now requires on Scalar::Defer 0.10. -audreyt * Jifty::DBI::Schema - Don't rescind &defer and &lazy after the schema{...} block and talks about how to use it. -sterling * debian changes -yves * export of defer in Jifty::DB::Schema kills symbols for other use (thx audreyt) -yves * Make load_by_cols work when a given value is undef by turning the query into IS NULL. -clkao * Completely finish porting Jifty::DBI::Schema to use Object::Declare. clkao, audreyt Visible differences are: - "refers App::Class" is now an alias for "refers_to App::Class". - In refers/refers_to it is no longer neccessary to load App::Class beforehand; therefore circular references can now be expressed. - "length is 30" is now invalid; a compile-time exception will be raised that tells the user to use "maxlength is 40" instead. 0.39_9999 Fri Jan 26 21:30:48 CST 2007 - Removed unneccessary use of Devel::SimpleTrace. 0.39_999 Fri Jan 26 21:30:48 CST 2007 - Improved error message for "length is 42": Due to an incompatible API change, the "length" field in Jifty::DBI columns has been renamed to "max_length": column foo => length is 10; # NOT VALID Please write this instead: column foo => max_length is 10 # VALID - Calling 'column' within a schema class is an error: package TestApp::Address::Schema; column address => ...; # NOT VALID Please write this instead: package TestApp::Address; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column address => ...; # VALID }; 0.39_99 Fri Jan 26 19:57:48 CST 2007 - INCOMPATIBLE API CHANGE: "length is 42" must be written as "max_length is 42" instead. - Switch to Object::Declare for schema declaration, fixing many annoyances such as the inability for two modules to refer to each other in their columns. - "refers Foo::Bar", a new alias to "refers_to Foo::Bar". 0.34 Sun Jan 28 21:28:00 CST 2007 - Added a method to the schema generator to output the SQL for a single column 0.32 Fri Jan 26 20:51:12 CST 2007 - Improved deprecation warning for "length is 42": Due to an incompatible API change, the "length" field in Jifty::DBI columns has been renamed to "max_length": column foo => length is 10; # NOT VALID Please write this instead: column foo => max_length is 10 # VALID - Calling 'column' within a schema class is deprecated: package TestApp::Address::Schema; column address => ...; # NOT VALID Please write this instead: package TestApp::Address; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column address => ...; # VALID }; 0.31 Fri Jan 26 19:52:08 CST 2007 - load, load_by_cols, load_from_hash and create are now optionally class methods. - "length is 42" in schema declarations is deprecated; please write "max_length is 42" instead. - Jifty::DBI::Collection - document the "LIKE" and "MATCHES" limit operators correctly. 0.30 Wed Jan 17 15:29:44 EST 2007 - update version dependency on DateTime to 0.34 - fixed a "use of uninitialized value" warning in the tests. [t/01records.t] - Make sure we don't go looking for the validate_COLUMN sub everytime for columns without validators (thanks to Alex for pointing that out) - Fix bug where validator_COLUMN subs weren't getting set as validators (thanks to Audrey for help) - Test that the declarative syntax automagically sets validators as it should (these fail at the moment, though a fix should be forthcoming) - fixed the "order_by" bug in sub distinct_query. [Jifty::DBI::Handle::Pg] - added unit tests for the Handle::Pg patch. [t/14handle-pg.t] - fixed the desc string in the last test. [t/13collection.t] - made _order_clause more flexible by dealing with empty aliases [lib/Jifty/DBI/Collection.pm] - added one test for it. [t/13collection.t] - added t/13collection.t to test methods in Jifty::DBI::Collection. - Jifty::DBI::Handle::ODBC - Bring in the missing build_dsn method from DBIx::SearchBuilder such that this backend can work again. Requested by: agentzh++ - Jifty::DBI::Column - Recognize "is autocompleted". - Jifty::DBI::Collection - The "function" argument to the "column" method was broken when passed with trailing "?" characters. - Also clean up the documentation about ->distinct_required. - Jifty::DBI::Collection - Document the long-undocumented ->column method. - Jifty::DBI::Handle::ODBC - Doc fixup and author name fixup. - Jifty::DBI::Schema - Add "is autocompleted". - Jifty::DBI::Schema - Backport "order is 3" as alias of "sort_order is 3" from Jifty::Param land. - Make "valid are ..." an alias for "valid_values are ..." for real. - add 'is indexed' syntax to the declaritive schema generator - remove sort, it causes CREATE INDEX to run before CREATE TABLE - add sqlite sql so that these tests run without needing postgres configured - reorganize the code so its easier to add more databases later, and uses util.pl more - Jifty::DBI::Collection - More CORE::join() to avoid warnings. - Jifty::DBI::Collection: Pass through the arguments to L to L and on to L - import Carp::croak so the error message in apply works 0.28, 0.29 Thu Nov 23 22:11:37 EST 2006 * The last upload didn't take 0.27 Thu Nov 23 22:06:09 EST 2006 * Initial implementation of prefetching for related records and collections 0.26 Mon Nov 13 11:11:31 EST 2006 Usability * avoid a warning in Jifty::DBI::Schema when our user is executing a .pm file. When that is the case, caller(1) is not defined. --gaal * Small error string change to suggest looking for missing use lines in models where refer_to is used --bartb Core code * fixed sort_order setting in Jifty::DBI::Schema --wolfgang * Don't use main.*, ever. --clkao * Jifty::DBI::Schema - Backport "valid are qw(...)" and "render as '...'" support from Jifty::Param::Schema as aliases to "valid_values are" and "render_as". --audreyt * added as_hash to Jifty::DBI::Record --jesse * @ISA => use base --schwern * Use DBIx::DBScehma::Column and ::Table rather than trust that DBIx::DBScehma will load them. --schwern Installation * Bump DateTime dependency, as older versions didn't provide the API we're using. (0.22 is known bad) --jesse (Thanks to Matt Trout) Testing * make sure to skip 04memcached.t if you don't have Cache::Memcached --ishigaki * Tests updated to not have $sth in scope when we $dbh->disconnect Doc * demonstrate the valid_values alternate syntax that allows display and value to be separate * Document columns and column --schwern * Minor changes to pod --evdb 0.25 Tue Sep 12 23:52:45 BST 2006 * cleaned up DSN generation. * Allowed arbitrary parameter specification in DSNs * Corrected the method name "DSN" to "dsn" throughout. * ( If a user tries to load a record by columns that happen ot be foriegn keys, and values that are objects, do the right thing * Propery cache DBI::Record entries when aliased. * Fewer accessor calls. * Only apply filters if we have values fetched. * make passing a J:D:Collection as a value DTRT * Jifty::DBI::Schema - s/die/croak/ to aid debugging. * Refactor Jifty::DBI::Filter::Date to be a subclass of ::Filter::DateTime. * New ::Filter::Time filter for time of day. ('time' sql type). * Update to Module::Install 0.64 to fix auto_install() when Makefile.PL is run from the command line and CPANPLUS is not installed. * The number of fixed tests in t/10schema.t for Jifty::DBI was wrong. * documented limit a bit more * JDBI::Filter::Date clones dates before setting timezone, so that we don't alter the object we're passed. * Spelling fixes. * Remove the @ISA-mocking code from Jifty::DBI::Schema, so that use MyApp::Record schema { ...; } can work even if MyApp::Record overrides Jifty::Record's column building methods. We do that by arranging the schema callback to run after the @ISA chain is set up. * Jifty::DBI::Schema - defer initialization for columns created via the schema{} wrapper, so that users can continue to define column names that overlaps with the helper functions, such as "label" and "type". * attempt to test "label" and "type" column definitions. however, as I don't have Pg, I cannot run this test; help welcome. * cleaned up case sensitivity code * fixed SQLite docs * abstract out checking whether it's possible to make a clause case insensitive so that subclasses of Handle can use those tests * doc'd Filter::DateTime special behavior when the column type is 'date' * Adding a filter to salt and hash passwords * Adding an after_set hook to Jifty::DBI::Record * Jifty::DBI::Schema: Lift the restriction to use another ::Schema package on the record model class; you can now directly write: package Wifty::Model::Page; use Jifty::DBI::Schema; schema { # ... your columns here ... }; because &schema will unregister all symbols exported by Jifty::DBI::Schema after it runs the column initialization code. Backward compatibility is preserved -- as long as you don't name your record model "Schema"... * update the testmodels.pl to use new schema decl syntax * Lift the call of schema to BEGIN time: * fixed handling of case sensitivity and numeric columns so opertions like '>' do numeric instead of lexical comparisons * Allow collection SELECTs to have preload_columns defined. * Case insensitive searches should be, euh, case insensitive in Pg * Mark case-sensitive tests as TODO for MySQL * drop ::Cachable::new as it does nothing * add cache tests: columns names are case insensetive so we should generate cache key insenstive too ::Cachable::_gen_record_cache_key * hash key couldn't be undefined, but '' and 0 are different keys * values undef, 0 and '' are different, use '__undef' only when it's really undef * apply the same logic when $value is hash reference * use lower case for key part ::Cachable::load_from_cache * don't generate PK cache key, we do that in subcequent _store call ::Cachable::__set * don't create local arguments hash, just pass @_ throught ::Cachable::__delete * don't eat arguments, may be somebody wants to subclass and pass arguments to delete. ::Cachable::_fetch * fetch again only when we found something in cache with keys' aliases ::Cachable::_primary_record_cache_key * avoid check for $self->id definess as if it's undef then record couldn't have pk cache key * use $self->primary_keys to get columns of the PK and its values, as result we get support for compound PKs here * Mark undef PK loading as TODO * Only mark the one failing test under mysql as TODO * make Collection smart about guessing table names * removed a lie from create() pod * Make _open_paren and _close_paren into public methods open_paren and close_paren 0.24 Tue Aug 8 23:33:34 EDT 2006 * artificial version increment 0.23 Thu Jun 15 14:12:20 CEST 2006 * Add tests for case sensitivity in limits * Caching for columns and readable/writable attributes. Only gains us 2% performance. But hey. 2% free * Added DateTime::Format::Strptime to requires * Do fewer ->COLUMNS calls from ->column, and do fewer ->column calls from ->value. * Make Jifty::DBI::Record::_init() expect a hash like Jifty::Record does * Fixes 'is_distinct' failure when used in Jifty * Use Class::Accessor::Fast. * Remove Carp::cluck, as it hates END and vice versa. * Integrate today's hack for dumping callers for sql queries in question. * Add tests for case sensitivity in limits * Integrate today's hack for dumping callers for sql queries in question. * Enforce mandatory things at a Jifty::DBI layer * Cleanup 'distinct' column check and tests * Tests for column constraints 'mandatory' and 'distinct' * Implement support for 'distinct' column checks * Perltidy * Set validator on the column to validate_whatever (even if it's just the autogenerated one) * Update Module::Install to 0.21+ to prevent make loop; also avoid the use of "our" in VERSION strings for compat with older MMs. (Ditto with the previous commit) * Oracle fixes from Mark Gardner * Jifty::DBI::Filter::Storable - Do not die when the storable image is somehow corrupt; instead, simply return undef. * upgrade inc/ trees to 0.62+ to reflect the version::vpp fix. * Jifty::DBI::Collection - minor POD style and typo fix. * add_record now works on empty collections * removed a debug warning from alex * Enforce "default is ''" on columns * Document the use and behavior of refers_to * Cache::Memcached was being tested whether or not it was installed. Thanks to Matt Trout * Fixed Pod typo * Doc fixes relating to filters * lib/Jifty/DBI/Record.pm - removed incorrect '=for' directive * lib/Jifty/DBI/SchemaGenerator.pm - removed incorrect '=for' directive * t/01-version_checks.t - test for CPAN VERSION parsing hang-ups * lib/Jifty/DBI/Record.pm - added Class::ReturnValue's to disallowed accessors * lib/Jifty/DBI/Record.pm - do not try to set_() a collection * t/11schema_records.t - added tests for trying to set a collection * t/10schema.t - silence undef warning * lib/Jifty/DBI/Record.pm - catch attempts to set a refers_to * lib/Jifty/DBI/SchemaGenerator.pm - crediting myself per Jesse's suggestion :-O (ewilhelm) * lib/Jifty/DBI/SchemaGenerator.pm - pod edits: Redid synopsis with real example -- maybe somewhat incorrect WRT Model::Schema, but it does work. Stripped boilerplate sections. Clarified add_model $model requirement. Cleanup odd =for public... pod bits. Spelling fix. * lib/Jifty/DBI/Handle.pm - documentation fixes/cleanup * created an api to allow distinct toggling 0.21 Wed May 3 14:14:41 EDT 2006 * We no longer do a count when setting up a collection's pager object by default * order_by now returns the current orders * added a "do_search" method to force a search, say before a count * Added a filter for Dates, lib/Jifty/DBI/Filter/Date.pm * Switched Jifty::DBI::Record to autocreate methods on object load rather than use AUTOLOAD. 0.20 Fri Apr 21 10:23:14 EDT 2006 * Documentation updates and misc bugfixes from Eric Wilhelm * Performance optimization for the "standard case" of __value * Postgres sequence parsing fix from Daniel Tabuenca 0.19 Sun Apr 2 18:59:53 JST 2006 * Columns now have a "sort_order" attribute. This way when auto-rendering forms, we can render them by "order defined" rather than just alphabetically. - idea by Tatsuhiko Miyagawa 0.18 Fri Mar 31 22:15:59 JST 2006 * Test fixes to remove databases after testing. This fixes Win32 test failures. -- Kenichi Ishigaki * Added "filters" method to records, which adds both input_filters and output_filters. 0.17 Sun Mar 5 00:41:41 PST 2006 * Memcached correctness fixes 0.16 Sat Mar 4 18:02:44 PST 2006 * Memcached installation fixes 0.15 * Added support for Memcached * Updated record docs to show hooks 0.09 Thu Dec 29 07:56:30 EST 2005 * Fixed dependency on Class::Data::Inheritable * Audrey Tang added "smarter" schema declaration processing to get us warnings on bogus usage. 0.08 Sun Dec 25 14:34:12 EST 2005 * Added a missing prereq: Exporter::Lite. Thanks to sri 0.06 Fri Dec 23 15:44:17 EST 2005 * Added more tests for mysql and Pg now that DBSchema supports them. Tests want more love 0.05_03 Forward-ported features from DBIx::SearchBuilder: 1.37_01 Thu Dec 8 15:56:50 EST 2005 * Switched Postgres sequence lookups to use CURRVAL, rather than OIDs 1.36 Fri Dec 2 18:04:21 EST 2005 * Change to how we resolve virtual columns to deal with a "no such attribute" bug in RT 1.35 Wed Nov 2 22:36:02 EST 2005 * Doc fixes and OrderBy cleanup from ruslan 1.34 Wed Nov 2 22:26:15 EST 2005 * Clone support from Ruslan 0.05_02 * Added support for "virtual" columns * Added support for named references between tables column owner => refers_to MyApp::User by 'email'; * not_null deprecated in favor of mandatory 0.05_01 Tue Nov 8 16:29:02 EST 2005 * Initial release Jifty-DBI-0.77/doc/0000755000175000017500000000000012246675115012716 5ustar chmrrchmrrJifty-DBI-0.77/doc/notes/0000755000175000017500000000000012246675115014046 5ustar chmrrchmrrJifty-DBI-0.77/doc/notes/on_intuitive_schema_definitions0000644000175000017500000003423711305565770022431 0ustar chmrrchmrr# so, what we have here is a conversion of the test suite. # I'm not 100% on the syntax, but I want to get it basically working. # the first thing I need to figure out is how the hell to get these functions # exported into Sample::Address and Sample::Employee. # use base does an @INC frob and a require. # it does _not_ do a 'use', which means we never call 'import'; package Sample::Address; # stinks of ingy, but: use Jifty::DBI::Record '-base'; # *laugh* I want better syntax than that. hm. But is the general concept ok? # maybe. I almost wonder whether we want a separate class for this. Jifty::DBI::Record->import(), actually ; # or could be: Jifty::DBI::Record->inherit; # or something (that means it has to be loaded already) # Well, sure, import would just work. # that's just evil. maybe right too. UNIVERSAL::import. It works sort of like UNIVERSAL::require. then you could have import Jifty::DBI::Record::SchemaFunctions# or something #not sure I like that, though. # would you want to have that *and* the use base though? # no. # if you're not trying to subclass, then I don't see what's wrong # with use Jifty::DBI::Record ':schemafunctions'; # which is standard Exporter.pm (@EXPORT_TAGS or whatever) *nod* #it feels a bit unclean. especially given what we're tyring to do. # # Yeah, I don't really like having the stuff pollute the namespace either. # if prototypes worked with methods I wouldn't even mind having to do $x = Jifty::DBI::SchemaBuilder->new; $x->define_blablalb $x->bla bla # (ok, maybe I'm being influenced by ruby again :) ) # (take a peek at the XML::Builder thing I checked into the SyncML tree sometime # for a simiarl issue) # not convinced ruby influence is bad.. # I sort of want to be able to take __PACKAGE__ and make an alias to it # CLASS-> or something # you just don't like the word __PACKAGE__ basically? # let me illustrate. # that's kind of the Class::DBI syntax, right? # yeah. and it pollutes everything. # and it doesn't let you *not* use () or magic sub{}s either :( # just look at that code. I see __PACKAGE__ and some lowercase stuff near it. # not "oh look, I have 3 fields" # yup. # *evil* our db_table 'addresses'; our field name => { has_type 'varchar'; has_default 'frank' }; # (by the way, i'm pretty sure we don't get to do the sub-at-t-end thing # either... I tried lots of hacky ways to get it working and failed.) # yeah, I think we're going to end up having a pseudo-sub that's really a hash behind the scenes # uh, ok, sothe ; has to become , probably. # probably. # worrying about htat bridge later # *nod*. So is it ok if db_table, field, etc end up in your model's namespace? # I think so. # I'd love to have that not true, but I'm not seeing it # Well, you probably could... no this is too wrong to imagine. # yes? { my $s = Jifty::DBI::SG->import_functions; db_table bla bla bla; field bla; field bar; } # $s.DESTROY gets called and unimports db_table/field/... # actually you might not even need the { } for that as long as nothing # else in the file ever refers to it. my $schema = Jifty::DBI::RecordSchema->new; $schema->for_class(__PACKAGE__); #just riffing $schema->field name => { has_type 'varchar'; has_default 'Frank'} #It's not quite metaprogramming enough or something. I really like the barewords # I'm not sure you saw what I meant -- you don't need the method calls my $s = Jifty::DBI::RecordSchema->new; field name => bla; __ENDOFFILEHERE__ (it does work, I just tested it). evil though. # yeah, you're using a destroy hack. # I'm not sure we need to worry about clearing out the namespace. # not sure we don't. # but it feels wrong to have it _stop_ working once the code is running. # well, it's wronger to modify the schema later :) # but anyway, what are you blocking on? # just how to get the functions exported? vvvvv? # I was blocking on whether to import the functions from the superclass, # as it somehow feels dirty. # oh. whether those functions belonged in Jifty::DBI::Record # or whether the schema was another object. but having played with that a bit # I think it results in more code and more disconnected code. # I think I agree that the record and the schema should be the same object. # but the "easy declaration macros" could come from somewhere else. maybe # that doesn't make sense. # don't forget that after all this fancy sytnax is set up we will still # need a way to declare schemas programmatically probably. # it's my expectation that the default sub schema will just read a datastructure that the fancy syntax populates # cool, that's what i was thinking too. (easiest way to implement too) # I was planning on lowercasing your hash keys. that make sense? # sounds good. i had no good reason for them to be in any particular case. # (it did kind of help make the difference between schema and form_fields # keys obvious, but that was just a lucky coincidence, not necessarily an # important feature.) # less "abusing" and more "never actually defined". # I've been finding a tiny impedance mismatch with how we do that anyway. # we're abusing 'type' # we're using it in two overlapping but incompatible ways ;) # what do you mean? i haven't poked at that in a while. # my belief is that the type that you declare in a schema should be a relatively # high-level description (not worrying about say "time vs timestamp vs datetime" # say) # the issue that comes up is "password" # generally, string fields are all rendered the same way. # hmm. how do we do that? # Have a look. I declared a subtype. it's not nice. # my feeling is that passwords should be a string in the schema but a password # in a form_fields, probably. # no, the schema needs to know not to give you a password accessor. oh, good point. then password should be # its own SG type :) # possibly. anyway. # so. we're back to the import. Let's find a good syntax :) # i mean, the standard perl way to say "import a bunch of functions" is use Jifty::DBI::Record ':schema'; #and I read that and don't know what it does. # No, _I_, have a sense of "oh it imports some functions" # you've never seen that before? huh. # but it doesn't read cleanly. it's a relatively unused perl semantic that I # don't like. # it may not be clean but it's perl # lots of things are perl. that doesn't make them right. # fortunately, if you can come up with anything to put into this blank: vvvvv use Jifty::DBI::Record ; # we can make it work. (including leaving it blank) # i feel like any statement other than a "use" or an explicit "import" # bringing functions into my namespace is unexpected and scary. (even # if it's better english grammar or something :) ) *nod* So, I _don't_ expect either a use or an import to mess with my inheritance chain. # except for use base, right. # sorry, yes. I don't expect another module. # well, i mean, there's always use base 'Jifty::DBI::Record'; # set up inheritance Jifty::DBI::Record->im_gonna_be_describing sym; # it should not be two statements. # this is what I've been trying to figure out. # yeah, but i think your constraints that you've said are contradictory # (1) should not be two statements # (2) only 'use base' should change inheritance # not what I think I said. "regular 'use' statements shouldn't mess with inheritance' # *nod* # (3) only use or something more explicit should export Anyway. # (ok, admittedly *I* said 3 :) but i think you agreed) # I'm not strong on 3. I wonder if I can force Jifty::DBI::Record to export into the current package's namespace when used, if and only if it's a subclass. When you say "when used" do you literally mean "when *use*d" or just "when you start calling functions in it" ? I guess you could make that work with BEGIN { @ISA = 'Jifty::DBI::Record' } use Jifty::DBI::Record; # but this sucks! use base qw/Jifty::DBI::Record/; __PACKAGE__->schema_version (0.0001) # or some other method that # does two thing evilly. # but you already told me that 'use base' doesn't call import. # ah, that could work. (i could believe it being __PACKAGE__->db_table) # except I want to be able to intuit that from classname # unless it's explicit. # will base let me pass anything in? time to hit source # i'm hitting it, and basically no. in fact once the base class # has been required once in your program's execution, all that # future use base calls is going to do is a push @package::ISA, $base_class; # we could tie @ISA #I'm kidding # we could replace base::import to do interesting things for classes that # match /^Jifty/ (it would be invisible too. and wrong.) # no, that's an ingy trick. # nah, i think ingy just makes you not use base. i think ours is more wrong :) #He actually replaces base:: on the fly # he showed me. # uch. never mind then. # we could just do another use statement # let me type, dude ;) # i still kind of feel like what you want is "i want perl to act like # not perl, but without any evil hacks" which seems tough. # yes.it's hard. possibly impossible. but if we can make it go, we win. # I don't mind two use statements. especially since we might be having # some records that don't use the special syntax use base qw/Jifty::DBI::Record/; use Jifty::DBI::Recordblablabla; or even: use base /Jifty::DBI::Record/; Jifty::DBI::Record->define_schema(); Jifty::DBI::Record->columns_from_code(); # instead of ->columns_from_db(); # but maybe a better name for it. # # yeah, that's good. I'd like that. # that seems the least insane so far. # but what do we call the method? # schema is perhaps a poor choice of word. Jifty::DBI::Record-> # i don't like columns, since we're defining foreign keys etc in the schema # but you see why it makes me twitch? # i do like the _from_code vs _from_db, since then you can also have # _from_hash etc etc *nod* Let's see how it plays: # I really, really want to be able to define my own subroutine like structures # well... : # Class and instance method use base 'Jifty::DBI::Record'; Jifty::DBI::Record->___from_code(); db_table 'addresses'; # legal! # AUTOLOAD? yup. # not sure that's ok. # also, not intuitive, i think. # and "code that is really a hash but looks like code" is? # at least the code that looks like code isn't embedding the column name in a sub call. # i just don't like it. # and I don't actually want it to be a hash. # I just haven't figured out a better way yet. # *nod* field { called 'name'; # ? # don't really like that, mostly because it's again hard to skim for. # are you just trying to get the {} block first? # basically. # *nod* # I want infix subs # well, you're not going to get it, without "sub " or source filters # (or switching languages :) ) # "we'll see" # part of this is to see how far I can get. since I know what "feel" # i want. # well, there's one bit of hope for getting infix subs actually # or, well, not really. you can get infix subs but you need to # but some weord there. by which point that word might as well # be "sub". OK, what you just wrote will work. (if you like it) # (well, except for needing a stupid semicolon on the end :( ) # It's not my favorite. # but yeah, falls into the "works" category" # and has_type 'string' # is definitely better than type => 'string' # in your book? # how would you do: refers_to_many RT::Tickets by 'owner'; # hmm. i thought about this before. we can do like simon and refers_to_many "RT::Tickets by owner"; # but I don't really like that. parsing is lame. # yeah, that's not ok. # see also "a pub has beers on taps" # I'm *pretty* sure that we can't get the line you've written to compile. # *maybe* by putting stuff into package 'by', but that's awful. unless it's RT::Tickets->refers_to_many(by(owner)); so you need to do sub by; i guess # pretty sure you gave me something similar. # oh no, autrijus gave me the one line I needed. # don't forget that RT::Tickets is a class/package. # shit! it actually works!!! # yeahi think i did but i didn't believe in it :) # although the code is running in the wrong place. but you # can figure out the right class using caller. # the idea is that it just returns a key, val pair. so it doesn't matter. # well, right, but refers_to_many is being called in RT::Tickets # instead of in the current package. but that's ok. 23:46 I've got a bad perl5 idea for you. Robert claims it's impossible 23:47 I'm trying to make the syntax "refers_to_many 'BTDT::Model::Tasks' by 'owner';" valid perl5 syntax. 23:47 I think I want "reverse overload" to make it go. But yeah. not possible. 23:47 We think Day changed to 07 Aug 2005 03:57 well, that may be true but you don't want that. 03:57 refers_to_many BTDT::Model::Tasks by 'owner' 03:57 is more readable and easily implemented. 03:58 sub by ($) { by => @_ } 03:58 done! 03:58 stop thinking classes as strings :) # so, now we're just still on the field foo => sub {}; issue # let's see what the hash syntax looks like with my weird keys. # actually i think i may need to go. # i'll leave this open for a bit if you want to type, but save it? # I'm going to switch back to vim, where I can code. But I'll check in these notes. # ok. later. field email => sub { has_type 'varchar'; has_default 'Frank'; }; field phone => { has_type 'varchar'; }; field employee_id => { refers_to_a Sample::Employee; } package Sample::Employee; use base qw/Jifty::DBI::Record/; __PACKAGE__->db_table 'employees'; __PACKAGE__->field name => has_type 'varchar'; __PACKAGE__->field dexterity => { has_type 'integer'}; 1; Jifty-DBI-0.77/ROADMAP0000644000175000017500000000530711305565770013164 0ustar chmrrchmrr 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. * 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. Parameter naming: Inside the object relational mapper (Jifty::DBI), when refering to a column, the parameter is called: 'column'. It is NOT called: 'field', 'key', 'col', etc . Jifty-DBI-0.77/META.yml0000644000175000017500000000211212246675062013417 0ustar chmrrchmrr--- build_requires: DBD::SQLite: 1.14 ExtUtils::MakeMaker: 6.59 Test::More: 0.52 Test::Warn: 0.1 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Jifty-DBI no_index: directory: - ex - inc - t requires: Cache::Memcached: 0 Cache::Simple::TimedExpiry: 0.21 Class::Accessor::Fast: 0 Class::Data::Inheritable: 0 Class::ReturnValue: 0.4 Class::Trigger: 0.12 Clone: 0 DBI: 0 DBIx::DBSchema: 0.34 Data::Page: 2.0 DateTime: 0.34 DateTime::Format::ISO8601: 0 DateTime::Format::Strptime: 0 Encode: 2.1 Exporter::Lite: 0 Hash::Merge: 0 Lingua::EN::Inflect: 0 Object::Declare: 0.22 Scalar::Defer: 0.1 Time::Duration: 0 Time::Duration::Parse: 0.06 UNIVERSAL::require: 0.11 URI: 0 YAML::Syck: 0 perl: 5.8.3 version: 0 resources: license: http://dev.perl.org/licenses/ repository: https://github.com/bestpractical/jifty-dbi version: 0.77 Jifty-DBI-0.77/README0000644000175000017500000001322211502103765013020 0ustar chmrrchmrrNAME Jifty::DBI - An object-relational persistence framework DESCRIPTION Jifty::DBI deals with databases, so that you don't have to. This module provides an object-oriented mechanism for retrieving and updating data in a DBI-accessible database. This module is the direct descendant of DBIx::SearchBuilder. If you're familiar with SearchBuilder, Jifty::DBI should be quite familiar to you. Purpose Jifty::DBI::Record abstracts the agony of writing the common and generally simple SQL statements needed to serialize and deserialize an object to the database. In a traditional system, you would define various methods on your object 'create', 'read', 'update', 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, Jifty::DBI::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. An Annotated Example The example code below makes the following assumptions: * The database is 'postgres', * The host is 'reason', * The login name is 'mhat', * The database is called 'example', * The table is called 'simple', * The table looks like so: id integer not NULL, primary_key(id), foo varchar(10), bar varchar(10) First, let's define our record class in a new module named "Simple.pm". use warnings; use strict; package Simple; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column foo => type is 'text'; column bar => type is 'text'; }; # your custom code goes here. 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. use Jifty::DBI::Handle; use Simple; Use two packages, the first is where I get the DB handle from, the latter is the object I just created. my $handle = Jifty::DBI::Handle->new(); $handle->connect( driver => 'Pg', database => 'test', host => 'reason', user => 'mhat', password => '' ); Creates a new Jifty::DBI::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. my $s = Simple->new( handle => $handle ); $s->load_by_cols(id=>1); load_by_cols Takes a hash of column => value pairs and returns the *first* to match. First is probably lossy across databases vendors. load_from_hash Populates this record with data from a Jifty::DBI::Collection. I'm currently assuming that Jifty::DBI is what we use in cases where we expect > 1 record. More on this later. Now that we have a populated object, we should do something with it! ::Record automagically generates accessors and mutators for us, so all we need to do is call the methods. accessors are named "column"(), and Mutators are named "set_column"($). On to the example, just appending this to the code from the last example. print "ID : ", $s->id(), "\n"; print "Foo : ", $s->foo(), "\n"; print "Bar : ", $s->bar(), "\n"; That's all you have to to get the data, now to change the data! $s->set_bar('NewBar'); Pretty simple! That's really all there is to it. Set($) returns a boolean and a string describing the problem. Lets look at an example of what will happen if we try to set a 'Id' which we previously defined as read only. my ($res, $str) = $s->set_id('2'); if (! $res) { ## Print the error! print "$str\n"; } The output will be: >> Immutable column 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 and 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 columns. ## Get a new record object. $s1 = Simple->new( handle => $handle ); my ($id, $status_msg) = $s1->create(id => 4, foo => 'Foooooo', bar => 'Barrrrr'); Poof! A new row in the database has been created! Now lets delete the object! my $s2 = Simple->new( handle => $handle ); $s2->load_by_cols(id=>4); $s2->delete(); And it's gone. For simple use, that's more or less all there is to it. In the future, I hope to expand this how-to to discuss using container classes, overloading, and what ever else I think of. LICENSE Jifty::DBI is Copyright 2005-2010 Best Practical Solutions, LLC. Jifty::DBI is distributed under the same terms as Perl itself. Jifty-DBI-0.77/debian/0000755000175000017500000000000012246675115013373 5ustar chmrrchmrrJifty-DBI-0.77/debian/rules0000755000175000017500000000353611305565770014462 0ustar chmrrchmrr#!/usr/bin/make -f # This debian/rules file is provided as a template for normal perl # packages. It was created by Marc Brockschmidt for # the Debian Perl Group (http://pkg-perl.alioth.debian.org/) but may # be used freely wherever it is useful. # # It was later modified by Jason Kohles # http://www.jasonkohles.com/ to support Module::Build installed modules # Uncomment this to turn on verbose mode. #export DH_VERBOSE=1 # If set to a true value then MakeMaker's prompt function will # always return the default without waiting for user input. export PERL_MM_USE_DEFAULT=1 PACKAGE=$(shell dh_listpackages) ifndef PERL PERL = /usr/bin/perl endif #TMP =$(CURDIR)/debian/$(PACKAGE) TMP =$(CURDIR)/debian/libjifty-dbi-perl build: build-stamp build-stamp: dh_testdir # Add commands to compile the package here $(PERL) Makefile.PL installdirs=vendor $(MAKE) $(MAKE) test touch build-stamp clean: dh_testdir dh_testroot # Add commands to clean up after the build process here -$(MAKE) clean dh_clean build-stamp install-stamp install: build install-stamp install-stamp: dh_testdir dh_testroot dh_clean -k # Add commands to install the package into debian/$PACKAGE_NAME here $(MAKE) install DESTDIR=$(CURDIR)/debian/libjifty-dbi-perl touch install-stamp binary-arch: # We have nothing to do by default. binary-indep: build install dh_testdir dh_testroot # dh_installcron # dh_installmenu # dh_installexamples dh_installdocs README dh_installchangelogs Changes dh_perl dh_link dh_strip dh_compress dh_fixperms dh_installdeb dh_gencontrol dh_md5sums dh_builddeb source diff: @echo >&2 'source and diff are obsolete - use dpkg-source -b'; false binary: binary-indep binary-arch .PHONY: build clean binary-indep binary-arch binary Jifty-DBI-0.77/debian/README0000644000175000017500000000077211305565770014261 0ustar chmrrchmrrThis directory contains Debian packaging files for Jifty::DBI. It is currently at a very early stage of development and is hardly tested. I have Built it under Ubuntu Dapper with two perl modules from Edgy. Another two modules were built from cpan using dh-make-perl. A more complete list of instructions will follow and I'll probably host a apt repository until such time as sufficient packages exist in mainstream Debian or Ubuntu to install without any other packages being required. Bart Bunting Jifty-DBI-0.77/debian/control0000644000175000017500000000162411305565770015001 0ustar chmrrchmrrSource: libjifty-dbi-perl Section: perl Priority: optional Maintainer: Yves Agostini Package: libjifty-dbi-perl Section: perl Architecture: all Depends: ${perl:Depends}, libcache-simple-timedexpiry-perl (>> 0.21), libclass-accessor-perl, libclass-data-inheritable-perl, libclass-trigger-perl (>> 0.12), libclass-returnvalue-perl (>> 0.40), libclone-perl, libdbi-perl, libdbix-dbschema-perl (>> 0.33), libdata-page-perl, libdatetime-perl (>> 0.34), libdatetime-format-iso8601-perl, libdatetime-format-strptime-perl, libexporter-lite-perl, libhash-merge-perl, liblingua-en-inflect-perl, libobject-declare-perl (>> 0.22), libuniversal-require-perl (>> 0.11), libscalar-defer-perl (>> 0.10), libversion-perl, perl-modules (>> 0.52), libdbd-sqlite3-perl, libyaml-syck-perl, libtime-duration-perl, libtime-duration-parse-perl Recommends: libcache-memcached-perl Description: Jifty DBI Jifty DBI Jifty-DBI-0.77/debian/compat0000644000175000017500000000000211305565770014571 0ustar chmrrchmrr5 Jifty-DBI-0.77/debian/changelog0000644000175000017500000000373211305565770015252 0ustar chmrrchmrrlibjifty-dbi-perl (0.48-1) unstable; urgency=low * 0.48 -- AGOSTINI Yves Fri, 25 Jan 2008 11:02:45 +0100 libjifty-dbi-perl (0.42-1) unstable; urgency=low * 0.42 -- AGOSTINI Yves Tue, 21 Aug 2007 10:34:15 +0200 libjifty-dbi-perl (0.41-1) unstable; urgency=low * 0.41 -- AGOSTINI Yves Wed, 2 May 2007 10:16:36 +0200 libjifty-dbi-perl (0.40-1) unstable; urgency=low * 0.40 -- Agostini yves Sun, 15 Apr 2007 21:10:58 +0200 libjifty-dbi-perl (0.39-1) unstable; urgency=low * 0.39 -- AGOSTINI Yves Fri, 9 Mar 2007 15:45:43 +0100 libjifty-dbi-perl (0.34-1) unstable; urgency=low * 0.34 -- AGOSTINI Yves Mon, 29 Jan 2007 09:48:25 +0100 libjifty-dbi-perl (0.32-1) unstable; urgency=low * deprecated use of length * deprecated use of column whitout schema -- AGOSTINI Yves Fri, 26 Jan 2007 14:47:37 +0100 libjifty-dbi-perl (0.31-1) unstable; urgency=low * - load, load_by_cols, load_from_hash and create are now optionally class methods. - "length is 42" in schema declarations is deprecated; please write "max_length is 42" instead. - Jifty::DBI::Collection - document the "LIKE" and "MATCHES" limit operators correctly. -- AGOSTINI Yves Fri, 26 Jan 2007 12:44:23 +0100 libjifty-dbi-perl (0.30-1) unstable; urgency=low * New cpan release -- AGOSTINI Yves Thu, 18 Jan 2007 08:54:39 +0100 libjifty-dbi-perl (0.29-1) unstable; urgency=low * Initial debianisation. -- Bart Bunting Sat, 13 Jan 2007 14:20:12 +1000 libjifty-dbi-perl (0.26-1) unstable; urgency=low * New cpan release -- AGOSTINI Yves Wed, 24 Nov 2006 21:08:26 +0200 libjifty-dbi-perl (0.24-1) unstable; urgency=low * Initial debianisation. -- Bart Bunting Mon, 21 Aug 2006 15:30:31 +1000 Jifty-DBI-0.77/Makefile.PL0000755000175000017500000000273112246674761014137 0ustar chmrrchmrruse inc::Module::Install; name ('Jifty-DBI'); license ('perl'); version_from('lib/Jifty/DBI.pm'); perl_version('5.8.3'); repository('https://github.com/bestpractical/jifty-dbi'); requires('Cache::Simple::TimedExpiry' => '0.21'); requires('Class::Accessor::Fast' => 0); requires('Class::Data::Inheritable'); requires('Class::ReturnValue', 0.40); requires('Class::Trigger', 0.12); requires('Clone'); requires('DBI'); requires('DBIx::DBSchema' => '0.34'); requires('Data::Page' => '2.0'); requires('DateTime' => 0.34); requires('DateTime::Format::ISO8601'); requires('DateTime::Format::Strptime'); requires('Encode' => 2.10); requires('Exporter::Lite'); requires('Hash::Merge'); requires('Lingua::EN::Inflect'); requires('Object::Declare' => 0.22); requires('UNIVERSAL::require' => 0.11); requires('Scalar::Defer' => 0.10); requires('version'); #requires('Class::Trigger'); build_requires('Test::More' => 0.52); build_requires('Test::Warn' => 0.10); build_requires('DBD::SQLite' => 1.14); no_index directory => 'ex'; features( 'Memcached support' => [ -default => ($^O eq 'MSWin32'?0:1), 'Cache::Memcached' => '' ], 'YAML filter' => [ -default => 1, (can_cc() ? requires('YAML::Syck') : requires('YAML')), ], 'Duration filter' => [ -default => 1, 'Time::Duration' => '', 'Time::Duration::Parse' => '0.06', ], 'URI filter' => [ -default => 1, 'URI' => '', ], ); auto_install(); sign; &WriteAll; Jifty-DBI-0.77/ex/0000755000175000017500000000000012246675115012565 5ustar chmrrchmrrJifty-DBI-0.77/ex/Example/0000755000175000017500000000000012246675115014160 5ustar chmrrchmrrJifty-DBI-0.77/ex/Example/Model/0000755000175000017500000000000012246675115015220 5ustar chmrrchmrrJifty-DBI-0.77/ex/Example/Model/Address.pm0000644000175000017500000000052411305565770017144 0ustar chmrrchmrrpackage Example::Model::Address; use base qw/Jifty::DBI::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;Jifty-DBI-0.77/ex/Example/Model/Employee.pm0000644000175000017500000000032611305565770017336 0ustar chmrrchmrrpackage Example::Model::Employee; use base qw/Jifty::DBI::Record/; sub Table { "Employees" } sub Schema { return { Name => { type => 'varchar', }, Dexterity => { type => 'integer', }, } } 1;Jifty-DBI-0.77/ex/create_tables.pl0000644000175000017500000000316411305565770015723 0ustar chmrrchmrr#!/usr/bin/env 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 Jifty::DBI::Handle; use Jifty::DBI::SchemaGenerator; my $BaseClass; BEGIN { unless (@ARGV) { die < $BaseClass, sub_name => 'models', instantiate => 'new'; my $handle = Jifty::DBI::Handle->new; $handle->Connect( @CONNECT_ARGS ); my $SG = Jifty::DBI::SchemaGenerator->new($handle); die "Couldn't make SchemaGenerator" unless $SG; for my $model (__PACKAGE__->models) { my $ret = $SG->add_model($model); $ret or die "couldn't add model $model: ".$ret->error_message; } print $SG->create_table_sql_text; Jifty-DBI-0.77/inc/0000755000175000017500000000000012246675115012722 5ustar chmrrchmrrJifty-DBI-0.77/inc/Module/0000755000175000017500000000000012246675115014147 5ustar chmrrchmrrJifty-DBI-0.77/inc/Module/Install.pm0000644000175000017500000003013512246675060016114 0ustar chmrrchmrr#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.005; 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.06'; # 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::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); 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::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $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( 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($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD 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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _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. Jifty-DBI-0.77/inc/Module/Install/0000755000175000017500000000000012246675115015555 5ustar chmrrchmrrJifty-DBI-0.77/inc/Module/Install/Can.pm0000644000175000017500000000615712246675061016625 0ustar chmrrchmrr#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.06'; @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; 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 236 Jifty-DBI-0.77/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612246675061017646 0ustar chmrrchmrr#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; Jifty-DBI-0.77/inc/Module/Install/Base.pm0000644000175000017500000000214712246675061016771 0ustar chmrrchmrr#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # 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 Jifty-DBI-0.77/inc/Module/Install/Metadata.pm0000644000175000017500000004327712246675061017650 0ustar chmrrchmrr#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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 hashs 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; Jifty-DBI-0.77/inc/Module/Install/Win32.pm0000644000175000017500000000340312246675061017015 0ustar chmrrchmrr#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; Jifty-DBI-0.77/inc/Module/Install/AutoInstall.pm0000644000175000017500000000416212246675061020355 0ustar chmrrchmrr#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; Jifty-DBI-0.77/inc/Module/Install/Makefile.pm0000644000175000017500000002743712246675061017645 0ustar chmrrchmrr#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.06'; @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-seperated 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 Jifty-DBI-0.77/inc/Module/Install/Include.pm0000644000175000017500000000101512246675061017473 0ustar chmrrchmrr#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; Jifty-DBI-0.77/inc/Module/Install/Fetch.pm0000644000175000017500000000462712246675061017155 0ustar chmrrchmrr#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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; Jifty-DBI-0.77/inc/Module/AutoInstall.pm0000644000175000017500000006216212246675061016753 0ustar chmrrchmrr#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # 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::cwd(); $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 combatability 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 ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @installed; @installed = (); } 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} = $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::cwd() ); 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 1193 Jifty-DBI-0.77/MANIFEST0000644000175000017500000000453212246674606013312 0ustar chmrrchmrr.gitignore Changes debian/changelog debian/compat debian/control debian/README debian/rules doc/notes/on_intuitive_schema_definitions 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/Jifty/DBI.pm lib/Jifty/DBI/Collection.pm lib/Jifty/DBI/Collection/Union.pm lib/Jifty/DBI/Collection/Unique.pm lib/Jifty/DBI/Column.pm lib/Jifty/DBI/Filter.pm lib/Jifty/DBI/Filter/base64.pm lib/Jifty/DBI/Filter/Boolean.pm lib/Jifty/DBI/Filter/Date.pm lib/Jifty/DBI/Filter/DateTime.pm lib/Jifty/DBI/Filter/Duration.pm lib/Jifty/DBI/Filter/SaltHash.pm lib/Jifty/DBI/Filter/Storable.pm lib/Jifty/DBI/Filter/Time.pm lib/Jifty/DBI/Filter/Truncate.pm lib/Jifty/DBI/Filter/URI.pm lib/Jifty/DBI/Filter/utf8.pm lib/Jifty/DBI/Filter/YAML.pm lib/Jifty/DBI/Handle.pm lib/Jifty/DBI/Handle/Informix.pm lib/Jifty/DBI/Handle/mysql.pm lib/Jifty/DBI/Handle/mysqlPP.pm lib/Jifty/DBI/Handle/ODBC.pm lib/Jifty/DBI/Handle/Oracle.pm lib/Jifty/DBI/Handle/Pg.pm lib/Jifty/DBI/Handle/SQLite.pm lib/Jifty/DBI/Handle/Sybase.pm lib/Jifty/DBI/HasFilters.pm lib/Jifty/DBI/Record.pm lib/Jifty/DBI/Record/Cachable.pm lib/Jifty/DBI/Record/Memcached.pm lib/Jifty/DBI/Record/Plugin.pm lib/Jifty/DBI/Schema.pm lib/Jifty/DBI/SchemaGenerator.pm Makefile.PL MANIFEST This list of files META.yml README ROADMAP SIGNATURE t/00.load.t t/01-version_checks.t t/01basics.t t/01records.t t/01searches.t t/02-column_constraints.t t/02records_cachable.t t/02records_object.t t/02searches_distinct_values.t t/02searches_joins.t t/03rebless.t t/03rename_column.t t/03rename_table.t t/04memcached.t t/05raw_value.t t/06filter.t t/06filter_base64.t t/06filter_boolean.t t/06filter_datetime.t t/06filter_duration.t t/06filter_salthash.t t/06filter_storable.t t/06filter_truncate.t t/06filter_utf8.t t/06filter_yaml.t t/10schema.t t/11schema_records.t t/12prefetch.t t/13collection.t t/14handle-pg.t t/15types.t t/16inheritance.t t/17virtualtypes.t t/18triggers.t t/19reference.t t/20overload.t t/99-pod-coverage.t t/99-pod-spelling.t t/99-pod.t t/99-tabs.t t/case_sensitivity.t t/metadata.t t/testmodels.pl t/utils.pl Jifty-DBI-0.77/SIGNATURE0000644000175000017500000001736512246675115013451 0ustar chmrrchmrrThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.69. 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: SHA1 SHA1 812aba5682ab0d585d430938a048041041bcce40 .gitignore SHA1 60f97f46a35d5a5b7b69811979cf437a33b9dd6a Changes SHA1 c2fb135f967d7093a6191d1b7e5e596e30040246 MANIFEST SHA1 835de56b86ecb6c2161515194614b5d37b281a08 META.yml SHA1 6f7e7af1f5e2a4c262d66da84dd07094676b4ef0 Makefile.PL SHA1 e29d7b270f78a5a406921571b08290c46f2a42f6 README SHA1 82d6ac3f6def48558d09f8b6e3b53ed4194d8c81 ROADMAP SHA1 9d304f35438f847863969f6a069598379f5a9db2 debian/README SHA1 00b43188583b43d0c5f953a9b4be027a1f61404b debian/changelog SHA1 5d9474c0309b7ca09a182d888f73b37a8fe1362c debian/compat SHA1 585fdbb668c1537387d855eb894bc5c987c024d8 debian/control SHA1 c1085db4f95bd6e7e7470ccab55f8adba10d5024 debian/rules SHA1 c28087e498978a1a314dfcaa584844703f31ac8c doc/notes/on_intuitive_schema_definitions SHA1 584c0f6cdebcbf760dfca8413c94783586120214 ex/Example/Model/Address.pm SHA1 7cea1a5289f79c2a87837924a83feb583f6e8890 ex/Example/Model/Employee.pm SHA1 a9d62e4f5b43b2f78066172a4771238ee7df6339 ex/create_tables.pl SHA1 06c410f05488c1612ed66b06d3a86b2580581e4a inc/Module/AutoInstall.pm SHA1 8a924add836b60fb23b25c8506d45945e02f42f4 inc/Module/Install.pm SHA1 61ab1dd37e33ddbe155907ce51df8a3e56ac8bbf inc/Module/Install/AutoInstall.pm SHA1 2d0fad3bf255f8c1e7e1e34eafccc4f595603ddc inc/Module/Install/Base.pm SHA1 f0e01fff7d73cd145fbf22331579918d4628ddb0 inc/Module/Install/Can.pm SHA1 7328966e4fda0c8451a6d3850704da0b84ac1540 inc/Module/Install/Fetch.pm SHA1 66d3d335a03492583a3be121a7d888f63f08412c inc/Module/Install/Include.pm SHA1 b62ca5e2d58fa66766ccf4d64574f9e1a2250b34 inc/Module/Install/Makefile.pm SHA1 1aa925be410bb3bfcd84a16985921f66073cc1d2 inc/Module/Install/Metadata.pm SHA1 e4196994fa75e98bdfa2be0bdeeffef66de88171 inc/Module/Install/Win32.pm SHA1 c3a6d0d5b84feb3280622e9599e86247d58b0d18 inc/Module/Install/WriteAll.pm SHA1 7060e9387e72ab5f23e520b1ecbb9a94ae101384 lib/Jifty/DBI.pm SHA1 baa6d39bf6c7aec2fb82e96e512a2a7d3da15086 lib/Jifty/DBI/Collection.pm SHA1 503ca4cf6693580dedf8adee58267532f8467908 lib/Jifty/DBI/Collection/Union.pm SHA1 bcba77fd2bacf0475aea1de97f57365c8de92ca6 lib/Jifty/DBI/Collection/Unique.pm SHA1 c1040807672358fb8a998c13e908dfcd43ac3c48 lib/Jifty/DBI/Column.pm SHA1 9f6a6435d358a79108e98e379e252139457c1e9f lib/Jifty/DBI/Filter.pm SHA1 05d100a1a9cd24c6c0285660edf3758d5f04c1c7 lib/Jifty/DBI/Filter/Boolean.pm SHA1 d0addaa43cfa8950cb33d42a364a3c3c56a2dd59 lib/Jifty/DBI/Filter/Date.pm SHA1 0fd9a9a59d4220ea20b75c7214ebd5a2619a4f5d lib/Jifty/DBI/Filter/DateTime.pm SHA1 561ee05d174cb1a40be59cd1ef271b6a6c458d27 lib/Jifty/DBI/Filter/Duration.pm SHA1 79649ca3fb9f8aa9d2fdda00d6d7c7c99fe4092f lib/Jifty/DBI/Filter/SaltHash.pm SHA1 45ff3c7d2c03136acf98b74c659e2fe8c734d929 lib/Jifty/DBI/Filter/Storable.pm SHA1 13837e1f389b4e2e60e8b2395b327604ec7e25b6 lib/Jifty/DBI/Filter/Time.pm SHA1 900abc76b7e230934571a597132e520a231f92c3 lib/Jifty/DBI/Filter/Truncate.pm SHA1 6dcb8ad9a3b858bdb76fe62ddf1f483701e1f918 lib/Jifty/DBI/Filter/URI.pm SHA1 67ffe7188a1f529d7594f4fa3803bcbe15ba6485 lib/Jifty/DBI/Filter/YAML.pm SHA1 a0ba8e98fd032ef018bf2119adc2b2c4d1619450 lib/Jifty/DBI/Filter/base64.pm SHA1 ad030f4ec217584bedef2fe2720e4f9b1bc5af19 lib/Jifty/DBI/Filter/utf8.pm SHA1 82594c1948a59f865873f03e896a24fbcb3fcd76 lib/Jifty/DBI/Handle.pm SHA1 719a11c911aac5306baa4b44f683aa76261100c7 lib/Jifty/DBI/Handle/Informix.pm SHA1 338116a45f8eb6bfca5e76e8d3be78fb61fffe81 lib/Jifty/DBI/Handle/ODBC.pm SHA1 8281a163b21bb4a5cb0f2b24ce4a55dab716c408 lib/Jifty/DBI/Handle/Oracle.pm SHA1 bb51b0281d27fefd0b0afebe1890c4b13eab2c24 lib/Jifty/DBI/Handle/Pg.pm SHA1 2f4c08340712bd21679282ebd669ce7b99d6d646 lib/Jifty/DBI/Handle/SQLite.pm SHA1 bba2314c20fcc3ef71cc69090f1cd6bd515cd9b4 lib/Jifty/DBI/Handle/Sybase.pm SHA1 cf80896a175702a157770f64ae469430678c3357 lib/Jifty/DBI/Handle/mysql.pm SHA1 f2cc4fcce79c9a88a023d4e6bd96c2089eef1ced lib/Jifty/DBI/Handle/mysqlPP.pm SHA1 af372dca1ebf532924f2209c65fdda8ea21c36e8 lib/Jifty/DBI/HasFilters.pm SHA1 41437eed66a8404df67c9516da6472db4b2c494d lib/Jifty/DBI/Record.pm SHA1 663978b31373520d1e2deec87e957d1dbfd1347c lib/Jifty/DBI/Record/Cachable.pm SHA1 d52720a641a75826ef3eeae26a17a0a2d20bc148 lib/Jifty/DBI/Record/Memcached.pm SHA1 53834b3315a509ba33a8647681f472d3ae7b0557 lib/Jifty/DBI/Record/Plugin.pm SHA1 c21f26b802ccf5a24db866ad4d6d1e3961f89892 lib/Jifty/DBI/Schema.pm SHA1 71ba2f402f5fc891be47f6be682200084f157d99 lib/Jifty/DBI/SchemaGenerator.pm SHA1 32834b7c4cf5a8d131382fccc8db341be8768291 t/00.load.t SHA1 9aa7fed2b2409faa4c71d2a45db210721f47403e t/01-version_checks.t SHA1 13c9fe3eeec0d000a7c86ea2474e30186cbc37e2 t/01basics.t SHA1 1a9831e19e42d1e8d8da0ed923d5e055c3bdebeb t/01records.t SHA1 7574130aa1dc5338b6efcd0f04eca3f6dc4b2696 t/01searches.t SHA1 df97ee4e5bcb4ef0663dcc1a8db86dc66e8d9206 t/02-column_constraints.t SHA1 1c2bd056c575bc74caf2e59bdda8d8eb2731a3e7 t/02records_cachable.t SHA1 33642a61fd4b5a88436a82c6dd0fef359ba74a2b t/02records_object.t SHA1 36df1d63579d2eaef4516ec3545460da046577d5 t/02searches_distinct_values.t SHA1 ac42d8f2eea9f4856bee130b3ca557ef13940ad4 t/02searches_joins.t SHA1 f1f330dd8b4144e3437aba1455053903306bd0bc t/03rebless.t SHA1 4a4ed7341a37aa1ba4ecc03ad73e120a4052eac9 t/03rename_column.t SHA1 cb788b5336ae7c6f1fbf7795e38e2c4441f5c216 t/03rename_table.t SHA1 62c42d8458d73898f47f1b72d757239747321ef5 t/04memcached.t SHA1 854be4bb9e4e9643900341ec688ff9ec021a28e7 t/05raw_value.t SHA1 f0371e275879019e2abe732bbb5626d0d05049a0 t/06filter.t SHA1 38b1446e2b030261ba943dbdd03c48dfb6c3765f t/06filter_base64.t SHA1 646947b41cfcddf80b627505940244aed2c6c5ea t/06filter_boolean.t SHA1 8d464426f2c5b0ab5ecc5a0a0331e5f77669c2dc t/06filter_datetime.t SHA1 172f655a7fdb4771e6e8b3aee45e93b1264a5567 t/06filter_duration.t SHA1 94ed632ca88c6094236eec59cffdb1f3fd39f551 t/06filter_salthash.t SHA1 1c0727c29fb58462710e4578a237d557b8453a07 t/06filter_storable.t SHA1 f0f6ce9d48f419de6ac6154684f9065f32e30ddd t/06filter_truncate.t SHA1 2e9777a47e3a920d063bfbf9d56375c67c5b89c5 t/06filter_utf8.t SHA1 bb91f506a251d7b27d2fcd29c482a345318ef04f t/06filter_yaml.t SHA1 3b94f4d11b550cb97e49ca3dec782e064ff29e70 t/10schema.t SHA1 f4b0e5a9c9c22b873f12551e8b4aea7592fd94d3 t/11schema_records.t SHA1 164ebb7144e978617c81306f5017bdcbcf41b801 t/12prefetch.t SHA1 6792dbe544de8f24dccf9c412b96c913b4ff6388 t/13collection.t SHA1 be7d8495eb1daee249f17af18be1ec9f41c66b8a t/14handle-pg.t SHA1 4f41229caa246bf6ebb369010deb0c1eb8809666 t/15types.t SHA1 5958e59e29d29fbf3862b5d3471472cbd82d191e t/16inheritance.t SHA1 c7004285662f16abca274918f86d17ea43fe8c90 t/17virtualtypes.t SHA1 32457dd407414a89bd82d7fe59afab1014f8f920 t/18triggers.t SHA1 befc46d5364088775b6dda5ae1cf970c1b0fa4e8 t/19reference.t SHA1 72a16ddfc2642564023448450f3475ae5abf6d86 t/20overload.t SHA1 0e7ceb6deb91ae0c15bbd42f946b65a44e704706 t/99-pod-coverage.t SHA1 23ed1811c0c3d28c4585965f450a5140ffafe813 t/99-pod-spelling.t SHA1 8841b06de7875ffba985ce82c347737ca098aa1a t/99-pod.t SHA1 82ee6497512299eea11063a3610d4fbc429d49b6 t/99-tabs.t SHA1 5e1158a9340410d46ffad19f381982159dccc924 t/case_sensitivity.t SHA1 f0ce911fe0b4bdc70fe9dbb524d8cd89bedfc904 t/metadata.t SHA1 97e60dd523a74a886c170eeb05b813aa551f5efe t/testmodels.pl SHA1 653c2f961d8b4f195e5391cd261f37815068e8d5 t/utils.pl -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.11 (GNU/Linux) iEYEARECAAYFAlKbek0ACgkQMflWJZZAbqDRxgCeMbPa7Wr2NSKCC84k84MOSet5 jdoAnjCvOPuMw3VhRqaAYX+DI00JQs55 =a7/M -----END PGP SIGNATURE----- Jifty-DBI-0.77/.gitignore0000644000175000017500000000017011647720424014135 0ustar chmrrchmrrMANIFEST MANIFEST.bak MYMETA.yml MYMETA.json Makefile Makefile.old SIGNATURE blib/ pm_to_blib .prove *.sw[po] cover_db/ Jifty-DBI-0.77/t/0000755000175000017500000000000012246675115012414 5ustar chmrrchmrrJifty-DBI-0.77/t/06filter_duration.t0000644000175000017500000000564011305565770016146 0ustar chmrrchmrr#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 42; eval "use Time::Duration ()"; if ($@) { plan skip_all => "Time::Duration not installed"; } eval "use Time::Duration::Parse ()"; if ($@) { plan skip_all => "Time::Duration::Parse not installed"; } my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; my @bad_input = ('foo'); my @duration_input = ('3h5m', '3:05', '3:04:60', '3h 0:05', '1h 2:04:60'); my $duration_output = '3h5m'; my $duration_seconds = 11100; foreach my $d (@available_drivers) { SKIP: { unless (has_schema('TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle($d); connect_handle($handle); isa_ok($handle->dbh, 'DBI::db'); { my $ret = init_schema('TestApp::User', $handle); isa_ok($ret, 'DBI::st', 'init schema'); } for my $input ( @bad_input ) { my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my ($id) = $rec->create( my_data => $input ); ok($id, 'created record'); ok($rec->load($id), 'loaded record'); is($rec->id, $id, 'record id matches'); is($rec->my_data, undef, 'my_data output is undef'); } for my $input ( @duration_input ) { my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my ($id) = $rec->create( my_data => $input ); ok($id, 'created record'); ok($rec->load($id), 'loaded record'); is($rec->id, $id, 'record id matches'); is($rec->my_data, $duration_output, 'my_data output is consistent'); my $sth = $handle->simple_query("SELECT my_data FROM users WHERE id = $id"); my ($seconds) = $sth->fetchrow_array; is( $seconds, $duration_seconds, 'my_data seconds match' ); # undef/NULL $rec->set_my_data; is($rec->my_data, undef, 'set undef value'); } cleanup_schema('TestApp', $handle); disconnect_handle($handle); } } package TestApp::User; use base qw/ Jifty::DBI::Record /; 1; sub schema_sqlite { < type is 'integer', filters are qw/ Jifty::DBI::Filter::Duration /; } } Jifty-DBI-0.77/t/99-pod-coverage.t0000644000175000017500000000111411547413324015403 0ustar chmrrchmrruse Test::More; plan skip_all => "Coverage tests only run for authors" unless (-d 'inc/.author'); eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok( ); # Workaround for dumb bug (fixed in 5.8.7) where Test::Builder thinks that # certain "die"s that happen inside evals are not actually inside evals, # because caller() is broken if you turn on $^P like Module::Refresh does # # (I mean, if we've gotten to this line, then clearly the test didn't die, no?) Test::Builder->new->{Test_Died} = 0; Jifty-DBI-0.77/t/13collection.t0000644000175000017500000000530511547413324015076 0ustar chmrrchmrr# Test methods in Jifty::DBI::Collection. use strict; use warnings; use Test::More tests => 10; my $package; BEGIN { $package = 'Jifty::DBI::Collection'; use_ok($package); } # # Test the _order_clause method # my $obj = bless { order_by => [ { alias => 'main', column => 'name', order => 'desc', }, { alias => 'foo', column => 'id', order => 'des', }, { alias => 'bar', column => 'msg_session', order => 'DesC', } ], }, $package; is $obj->_order_clause, ' ORDER BY main.name DESC, foo.id DESC, bar.msg_session DESC ', 'desc works'; ## $obj = bless { order_by => [ { alias => 'messages', column => 'name', order => 'asc', }, { alias => 'QQUsers', column => 'sent', order => 'ASC', }, { alias => 'stu_dents', column => 'msg_session', order => 'AsC', } ], }, $package; is $obj->_order_clause, ' ORDER BY messages.name ASC, QQUsers.sent ASC, stu_dents.msg_session ASC ', 'asc works'; ## $obj = bless { order_by => [ { alias => '', column => 'name', }, { alias => 0, column => 'sent', }, { alias => 'ab', column => 'msg_session', } ], }, $package; is $obj->_order_clause, ' ORDER BY name ASC, sent ASC, ab.msg_session ASC ', 'empty and false aliases'; $obj->add_order_by( { alias => 'ab', column => 'msg_id', order => 'DESC', }, { alias => 'main', column => 'yaks', }, ); is $obj->_order_clause, ' ORDER BY name ASC, sent ASC, ab.msg_session ASC, ab.msg_id DESC, main.yaks ASC ', "add_order_by doesn't thrash previous ordering"; $obj->order_by( alias => 'ab', column => 'msg_id', order => 'DESC', ); is $obj->_order_clause, ' ORDER BY ab.msg_id DESC ', "order_by does thrash previous ordering"; $obj->add_order_by( alias => 'main', column => 'yaks', ); is $obj->_order_clause, ' ORDER BY ab.msg_id DESC, main.yaks ASC ', "add_order_by works when passing a list-as-hash directly"; # test specifying just function $obj->order_by( function => 'min(foo)', ); is $obj->_order_clause, ' ORDER BY min(foo) ASC ', "order_by function and column works"; # test specifying function and column $obj->order_by( function => 'lower', column => 'name', order => 'DESC', ); is $obj->_order_clause, ' ORDER BY lower(main.name) DESC ', "order_by function and column works"; $obj->clear_order_by; is($obj->_order_clause, '', "clear_order_by works"); Jifty-DBI-0.77/t/19reference.t0000644000175000017500000001476211547413324014716 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 40; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { SKIP: { unless( has_schema( 'TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); {my $ret = init_schema( 'TestApp::User', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} {my $ret = init_schema( 'TestApp::Currency', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} {my $ret = init_schema( 'TestApp::Food', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} # USD my $usd = TestApp::Currency->new( handle => $handle ); isa_ok($usd, 'Jifty::DBI::Record'); my ($id) = $usd->create( name => "USD" ); ok($id, "got id"); ok($usd->load($id), "loaded the just created currency record (USD)"); is($usd->name, "USD", "same name"); # GBP my $gbp = TestApp::Currency->new(handle=>$handle); isa_ok($usd, 'Jifty::DBI::Record'); my ($gid) = $gbp->create( name => "GBP" ); ok($gid, "got id"); ok($gbp->load($gid), "loaded the just created currency record (GBP)"); is($gbp->name, "GBP", "same name"); my $rec = TestApp::Food->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my ($paella) = $rec->create( name => "paella" ); $rec->create( name => "nigiri" ); # create using currency string $rec = TestApp::User->new( handle => $handle ); ($id) = $rec->create( currency => 'USD' ); ok($id); ok($rec->load($id), "Loaded the record"); isa_ok($rec->currency, 'TestApp::Currency'); is($rec->currency->name, 'USD'); is( $rec->food, undef, 'null_reference option in effect' ); { no warnings 'once'; local *TestApp::User::null_reference = sub {0}; $rec->load($id); isa_ok($rec->food, 'TestApp::Food', 'referee is null but shuold still return an object'); is($rec->food->id, undef); } # create using currency object $rec = TestApp::User->new( handle => $handle ); ($id) = $rec->create( currency => $usd ); ok($id); ok($rec->load($id), "Loaded the record"); isa_ok($rec->currency, 'TestApp::Currency'); is($rec->currency->name, 'USD'); my $food = TestApp::Food->new( handle => $handle ); $food->load($paella); # create with undef, set using currency string $rec = TestApp::User->new( handle => $handle ); ($id) = $rec->create(food => $food); ok($id); ok($rec->load($id), "Loaded the record"); is($rec->currency, undef, 'No currency object'); $rec->set_currency('USD'); isa_ok($rec->currency, 'TestApp::Currency'); is($rec->currency->name, 'USD'); # create with undef, set using currency object $rec = TestApp::User->new( handle => $handle ); ($id) = $rec->create(food => $food); ok($id); ok($rec->load($id), "Loaded the record"); is($rec->currency, undef, 'No currency object'); $rec->set_currency($gbp); isa_ok($rec->currency, 'TestApp::Currency'); is($rec->currency->name, 'GBP'); # load_by_cols with object $rec = TestApp::User->new(handle=>$handle); $rec->load_by_cols( currency => $usd ); ok($rec->id, "got id"); is($rec->currency->name, "USD", "got currency"); # limit with object my $users = TestApp::UserCollection->new(handle => $handle); $users->limit( column => 'currency', value => $usd ); is($users->count, 3, "got 3 users"); is($users->first->currency->name, "USD", "got USD"); $users = TestApp::UserCollection->new(handle => $handle); $users->limit( column => 'currency', value => $gbp ); is($users->count, 1, "got 1 users"); # limit with mixed array $users = TestApp::UserCollection->new(handle => $handle); $users->limit( column => 'currency', value => [$gbp, 'USD'] ); is($users->count, 4, "got 4 users"); } } package TestApp::Currency; use base qw/Jifty::DBI::Record/; sub schema_sqlite { < type is 'varchar'; }; package TestApp::Food; use base qw/Jifty::DBI::Record/; sub schema_sqlite { < type is 'varchar'; }; package TestApp::User; use base qw/Jifty::DBI::Record/; sub schema_sqlite { < type is 'varchar', refers_to TestApp::Currency by 'name'; column food => refers_to TestApp::Food; }; package TestApp::UserCollection; use base qw/Jifty::DBI::Collection/; 1; Jifty-DBI-0.77/t/06filter_truncate.t0000644000175000017500000001012311305565770016136 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 15; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { SKIP: { unless( should_test( $d ) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); unless( has_schema( 'TestApp::User', $handle ) ) { skip "No schema for '$d' driver", TESTS_PER_DRIVER - 1; } {my $ret = init_schema( 'TestApp::User', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); # name would be truncated my($id) = $rec->create( login => "obra", name => "Jesse Vincent" ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); is($rec->login, 'obra', "Login is not truncated" ); is($rec->name, 'Jesse Vinc', "But name is truncated" ); # UTF-8 string with flag set use Encode (); ($id) = $rec->create( login => "\x{442}\x{435}\x{441}\x{442}", name => "test" ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); is(Encode::decode_utf8($rec->login), "\x{442}\x{435}", "Login is truncated to two UTF-8 chars" ); is($rec->name, 'test', "Name is not truncated" ); # this test fails on Pg because it doesn't like data that # has bytes in unsupported encoding, we should use 'bytea' # type for this test, but we don't have coverage for this # # scalar with cp1251 octets # $str = "\x{442}\x{435}\x{441}\x{442}\x{442}\x{435}\x{441}\x{442}"; # $str = Encode::encode('cp1251', $str); # ($id) = $rec->create( login => $str, name => "test" ); # ok($id, "Successfuly created ticket"); # ok($rec->load($id), "Loaded the record"); # is($rec->id, $id, "The record has its id"); # is($rec->login, "\xf2\xe5\xf1\xf2\xf2", "Login is truncated to five octets" ); # is($rec->name, 'test', "Name is not truncated" ); # check that filter also work for set_* operations $rec->set_login( 'ruz' ); $rec->set_name( 'Ruslan Zakirov' ); is($rec->login, "ruz", "Login is not truncated" ); is($rec->name, 'Ruslan Zak', "Name is truncated" ); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); } } package TestApp::User; use base qw/Jifty::DBI::Record/; sub schema_sqlite { < type is 'varchar(5)', default is ''; column name => type is 'varchar(10)', max_length is 10, default is ''; column disabled => type is 'int(4)', max_length is 4, default is 0; } } 1; Jifty-DBI-0.77/t/00.load.t0000644000175000017500000000163711305565770013745 0ustar chmrrchmrruse Test::More tests => 13; BEGIN { use_ok("Jifty::DBI::Collection"); } BEGIN { use_ok("Jifty::DBI::Handle"); } BEGIN { use_ok("Jifty::DBI::Handle::Informix"); } BEGIN { use_ok("Jifty::DBI::Handle::mysql"); } BEGIN { use_ok("Jifty::DBI::Handle::mysqlPP"); } BEGIN { use_ok("Jifty::DBI::Handle::ODBC"); } BEGIN { SKIP: { skip "DBD::Oracle is not installed", 1 unless eval { require DBD::Oracle }; use_ok("Jifty::DBI::Handle::Oracle"); } } BEGIN { use_ok("Jifty::DBI::Handle::Pg"); } BEGIN { use_ok("Jifty::DBI::Handle::Sybase"); } BEGIN { use_ok("Jifty::DBI::Handle::SQLite"); } BEGIN { use_ok("Jifty::DBI::Record"); } BEGIN { use_ok("Jifty::DBI::Record::Cachable"); } # Commented out until ruslan sends code. BEGIN { SKIP: { skip "Cache::Memcached is not installed", 1 unless eval { require Cache::Memcached }; use_ok("Jifty::DBI::Record::Memcached"); } } Jifty-DBI-0.77/t/02records_cachable.t0000644000175000017500000001701411305565770016211 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } use constant TESTS_PER_DRIVER => 42; our (@available_drivers); my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d (@available_drivers) { 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" );} { # simple, load the same thing from cache my $rec = TestApp::Address->new( handle => $handle ); isa_ok( $rec, 'Jifty::DBI::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 => $handle ); my ( $status, $msg ) = $rec_cache->load_by_cols( id => $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' ); } Jifty::DBI::Record::Cachable->flush_cache; { # load by name then load by id, check that we fetch from hash my $rec = TestApp::Address->new( handle => $handle ); ok( $rec->load_by_cols( name => 'Jesse' ), "Loaded the record" ); is( $rec->name, 'Jesse', "The record's name is Jesse" ); my $rec_cache = TestApp::Address->new( handle => $handle ); my ( $status, $msg ) = $rec_cache->load_by_cols( id => $rec->id ); ok( $status, 'loaded record' ); is( $rec_cache->id, $rec->id, 'the same record as we created' ); is( $msg, 'Fetched from cache', 'we fetched record from cache' ); } Jifty::DBI::Record::Cachable->flush_cache; { # load_by_cols and undef, 0 or '' values my $rec = TestApp::Address->new( handle => $handle ); my ($id) = $rec->create( name => 'Emptyphone', phone => '' ); ok( $id, "Created record #$id" ); ($id) = $rec->create( name => 'Zerophone', phone => 0 ); ok( $id, "Created record #$id" ); ($id) = $rec->create( name => 'Undefphone', phone => undef ); ok( $id, "Created record #$id" ); Jifty::DBI::Record::Cachable->flush_cache; ok( $rec->load_by_cols( phone => undef ), "Loaded the record" ); is( $rec->name, 'Undefphone', "Undefphone record" ); is( $rec->phone, undef, "phone number is undefined" ); ok( $rec->load_by_cols( phone => '' ), "Loaded the record" ); is( $rec->name, 'Emptyphone', "Emptyphone record" ); is( $rec->phone, '', "phone number is empty string" ); ok( $rec->load_by_cols( phone => 0 ), "Loaded the record" ); is( $rec->name, 'Zerophone', "Zerophone record" ); is( $rec->phone, 0, "phone number is zero" ); # XXX: next thing fails, looks like operator is mandatory # ok($rec->load_by_cols( phone => { value => 0 } ), "Loaded the record"); ok( $rec->load_by_cols( phone => { operator => '=', value => 0 } ), "Loaded the record" ); is( $rec->name, 'Zerophone', "Zerophone record" ); is( $rec->phone, 0, "phone number is zero" ); } Jifty::DBI::Record::Cachable->flush_cache; { # case insensetive columns names my $rec = TestApp::Address->new( handle => $handle ); ok( $rec->load_by_cols( name => 'Jesse' ), "Loaded the record" ); is( $rec->name, 'Jesse', "loaded record" ); my $rec_cache = TestApp::Address->new( handle => $handle ); my ( $status, $msg ) = $rec_cache->load_by_cols( name => 'Jesse' ); ok( $status, 'loaded record' ); is( $rec_cache->id, $rec->id, 'the same record as we created' ); is( $msg, 'Fetched from cache', 'we fetched record from cache' ); } Jifty::DBI::Record::Cachable->flush_cache; { my $rec = TestApp::Address->new( handle => $handle ); my ($id) = $rec->create( name => 'Metadata', metadata => { some => "values" } ); ok( $id, "Created record #$id" ); # Do a search, but only load the 'id' column my $search = TestApp::AddressCollection->new( handle => $handle ); $search->columns(qw/id/); $search->limit( column => 'name', value => 'Metadata'); $rec = $search->first; is( $rec->id, $id, "The record has its id" ); is_deeply( $rec->metadata, { some => "values" } , "Got decoded values"); my $cache = TestApp::Address->new( handle => $handle ); my ( $status, $msg ) = $cache->load($id); ok( $status, 'loaded record' ); is( $cache->id, $id, 'the same record as we created' ); is( $msg, 'Fetched from cache', 'we fetched record from cache' ); is_deeply( $cache->metadata, { some => "values" } , "Got decoded values"); } Jifty::DBI::Record::Cachable->flush_cache; cleanup_schema( 'TestApp::Address', $handle ); disconnect_handle($handle); } } # SKIP, foreach blocks 1; package TestApp::Address; use base qw/Jifty::DBI::Record::Cachable/; sub schema_mysql { < type is 'varchar(14)'; column phone => type is 'varchar(18)'; column address => type is 'varchar(50)', default is ''; column employee_id => type is 'int(8)'; column metadata => type is 'text', filters are 'Jifty::DBI::Filter::YAML'; } } package TestApp::AddressCollection; use base qw/Jifty::DBI::Collection/; use constant table => "addresses"; 1; Jifty-DBI-0.77/t/testmodels.pl0000644000175000017500000000673211375011517015134 0ustar chmrrchmrrpackage Sample::Employee; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column dexterity => type is 'integer'; column name => type is 'varchar', is indexed; column label => type is 'varchar'; column type => type is 'varchar'; column age => is computed; }; sub age { my $self = shift; return $self->dexterity * 2; } sub schema_sqlite { return q{ CREATE TABLE employees ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL , dexterity integer , name varchar , label varchar , type varchar ) ; CREATE INDEX employees1 ON employees (name) ; }; } sub schema_pg { return q{ CREATE TABLE employees ( id serial NOT NULL , dexterity integer , name varchar , label varchar , type varchar , PRIMARY KEY (id) ) ; CREATE INDEX employees1 ON employees (name) ; }; } package Sample::Address; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column employee_id => references Sample::Employee; column name => type is 'varchar', default is 'Frank'; column phone => type is 'varchar'; column street => type is 'varchar', since '0.2.4', till '0.2.8'; }; sub validate_name { 1 } my $schema_version = undef; sub schema_version { my $class = shift; my $new_schema_version = shift; $schema_version = $new_schema_version if defined $new_schema_version; return $schema_version; } sub schema_sqlite { return q{ CREATE TABLE addresses ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL , employee_id integer , name varchar DEFAULT 'Frank' , phone varchar ) ; } } sub schema_sqlite_024 { return q{ CREATE TABLE addresses ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL , employee_id integer , name varchar DEFAULT 'Frank' , phone varchar , street varchar ) ; } } sub schema_pg { return q{ CREATE TABLE addresses ( id serial NOT NULL , employee_id integer , name varchar DEFAULT 'Frank' , phone varchar , PRIMARY KEY (id) ) ; }; } sub schema_pg_024 { return q{ CREATE TABLE addresses ( id serial NOT NULL , employee_id integer , name varchar DEFAULT 'Frank' , phone varchar , street varchar , PRIMARY KEY (id) ) ; }; } package Sample::Corporation; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column name => type is 'varchar', is mandatory; column us_state => type is 'varchar', is mandatory, since '0.2.4', till '0.2.8'; }; sub schema_sqlite { return q{ CREATE TABLE corporations ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL , name varchar NOT NULL ) ; } } sub schema_sqlite_024 { return q{ CREATE TABLE corporations ( id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL , name varchar NOT NULL , us_state varchar NOT NULL ) ; } } sub schema_pg { return q{ CREATE TABLE corporations ( id serial NOT NULL , name varchar NOT NULL , PRIMARY KEY (id) ) ; }; } sub schema_pg_024 { return q{ CREATE TABLE corporations ( id serial NOT NULL , name varchar NOT NULL , us_state varchar NOT NULL , PRIMARY KEY (id) ) ; }; } sub schema_version { my $class = shift; my $new_schema_version = shift; $schema_version = $new_schema_version if defined $new_schema_version; return $schema_version; } 1; Jifty-DBI-0.77/t/06filter_salthash.t0000644000175000017500000000407011305565770016124 0ustar chmrrchmrr#!/usr/bin/env perl use strict; use warnings; use Test::More; use Digest::MD5 qw( md5_hex ); BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 10; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d (@available_drivers) { SKIP: { unless (has_schema('TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle($d); connect_handle($handle); isa_ok($handle->dbh, 'DBI::db'); { my $ret = init_schema('TestApp::User', $handle); isa_ok($ret, 'DBI::st', 'init schema'); } my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my ($id) = $rec->create( password => 'very-very-secret' ); ok($id, 'created record'); ok($rec->load($id), 'loaded record'); is($rec->id, $id, 'record id matches'); is(ref $rec->password, 'ARRAY', 'password is an ARRAY'); is(scalar @{ $rec->password }, 2, 'password array has 2 elements'); my ($hash, $salt) = @{ $rec->password }; is($hash, md5_hex('very-very-secret', $salt), 'password matches encoding'); # undef/NULL $rec->set_password; is($rec->password, undef, 'set undef value'); cleanup_schema('TestApp', $handle); disconnect_handle($handle); } } package TestApp::User; use base qw/ Jifty::DBI::Record /; 1; sub schema_sqlite { < type is 'text', filters are qw/ Jifty::DBI::Filter::SaltHash /; } } Jifty-DBI-0.77/t/06filter_yaml.t0000644000175000017500000000415111305565770015257 0ustar chmrrchmrr#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 9; eval "use YAML::Syck ()"; if ($@) { eval "use YAML ()"; if ($@) { plan skip_all => "neither YAML::Syck nor YAML is installed"; } } my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; my $complex_data = { foo => 'bar', baz => [ 1, 2, 3 ], }; foreach my $d (@available_drivers) { SKIP: { unless (has_schema('TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle($d); connect_handle($handle); isa_ok($handle->dbh, 'DBI::db'); { my $ret = init_schema('TestApp::User', $handle); isa_ok($ret, 'DBI::st', 'init schema'); } my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my ($id) = $rec->create( my_data => $complex_data ); ok($id, 'created record'); ok($rec->load($id), 'loaded record'); is($rec->id, $id, 'record id matches'); is(ref $rec->my_data, 'HASH', 'my_data is a HASH'); is_deeply($rec->my_data, $complex_data, 'my_data matches initial data'); # undef/NULL $rec->set_my_data; is($rec->my_data, undef, 'set undef value'); cleanup_schema('TestApp', $handle); disconnect_handle($handle); } } package TestApp::User; use base qw/ Jifty::DBI::Record /; 1; sub schema_sqlite { < type is 'text', filters are qw/ Jifty::DBI::Filter::YAML /; } } Jifty-DBI-0.77/t/99-pod.t0000644000175000017500000000032411547413324013614 0ustar chmrrchmrruse Test::More; plan skip_all => "Coverage tests only run for authors" unless (-d 'inc/.author'); eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Jifty-DBI-0.77/t/03rename_table.t0000644000175000017500000000250411305565770015363 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; use Jifty::DBI::Handle; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 7; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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 $sth; drop_table_if_exists( 'test', $handle ); drop_table_if_exists( 'test1', $handle ); $sth = $handle->simple_query("CREATE TABLE test (a int)"); ok $sth, 'created a table'; ok $handle->simple_query("insert into test values(1)"), "inserted a record"; is $handle->simple_query("select * from test")->fetchrow_hashref->{'a'}, 1, 'correct value'; $handle->rename_table( table => 'test', to => 'test1' ); is $handle->simple_query("select * from test1")->fetchrow_hashref->{'a'}, 1, 'correct value'; my @warnings; ok !eval { local $SIG{__WARN__} = sub { push @warnings, @_ }; $handle->simple_query("select * from test") }, "no test table anymore"; ok(@warnings, "got some warnings"); }} # SKIP, foreach blocks 1; Jifty-DBI-0.77/t/metadata.t0000644000175000017500000000362311547413324014360 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 6; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; use DateTime (); foreach my $d ( @available_drivers ) { SKIP: { unless( has_schema( 'TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); {my $ret = init_schema( 'TestApp::User', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my $col = $rec->column('name'); is($col->label, 'Name'); is($col->attributes->{arbitary_data}, 'fooo'); is_deeply($col->serialize_metadata, { type => 'varchar', label => 'Name', sort_order => 0, writable => 1, name => 'name', readable => 1 }); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); } } package TestApp::User; use base qw/Jifty::DBI::Record/; 1; sub schema_sqlite { < type is 'varchar', label is 'Name', arbitary_data is 'fooo'; }; 1; Jifty-DBI-0.77/t/utils.pl0000755000175000017500000002020211305565770014110 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use File::Temp (); use Jifty::DBI::Handle; =head1 VARIABLES =head2 @supported_drivers Array of all supported DBD drivers. =cut our @supported_drivers = Jifty::DBI::Handle->supported_drivers; =head2 @available_drivers Array that lists only drivers from supported list that user has installed. =cut our @available_drivers = Jifty::DBI::Handle->available_drivers; =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 = 'Jifty::DBI::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; } our $SQLITE_FILENAME; sub connect_sqlite { my $handle = shift; (undef, $SQLITE_FILENAME ) = File::Temp::tempfile(); return $handle->connect( driver => 'SQLite', database => $SQLITE_FILENAME); } sub connect_mysql { my $handle = shift; return $handle->connect( driver => 'mysql', database => $ENV{'JDBI_TEST_MYSQL'}, user => $ENV{'JDBI_TEST_MYSQL_USER'} || 'root', password => $ENV{'JDBI_TEST_MYSQL_PASS'} || '', ); } sub connect_pg { my $handle = shift; return $handle->connect( driver => 'Pg', database => $ENV{'JDBI_TEST_PG'}, user => $ENV{'JDBI_TEST_PG_USER'} || 'postgres', password => $ENV{'JDBI_TEST_PG_PASS'} || '', ); } sub connect_oracle { my $handle = shift; return $handle->Connect( driver => 'Oracle', # database => $ENV{'JDBI_TEST_ORACLE'}, user => $ENV{'JDBI_TEST_ORACLE_USER'} || 'test', password => $ENV{'JDBI_TEST_RACLE_PASS'} || 'test', ); } =head2 disconnect_handle Disconnects C<$handle> object. =cut sub disconnect_handle { my $call = "disconnect_". lc handle_to_driver( $_[0] ); return unless defined &$call; goto &$call; } =head2 disconnect_handle_with_driver($handle, $driver) Disconnects C<$handle> using driver C<$driver>. =cut sub disconnect_handle_with_driver { my $call = "disconnect_". lc $_[1]; return unless defined &$call; @_ = $_[0]; goto &$call; } sub disconnect_sqlite { my $handle = shift; $handle->disconnect; unlink $SQLITE_FILENAME; } sub disconnect_mysql { my $handle = shift; $handle->disconnect; # XXX: is there something we should do here? } sub disconnect_pg { my $handle = shift; $handle->disconnect; # XXX: is there something we should do here? } =head2 should_test $driver 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 = 'JDBI_TEST_'. uc $driver; return $ENV{$env}; } =head2 has_schema $class { $driver | $handle } Returns method name if C<$class> has schema for C<$driver> or C<$handle>. If second argument is handle object then checks also for DB version specific schemas, for example for MySQL 4.1.23 this function will check next methods in the C<$class>: C, C, C and C, but if second argument is C<$driver> name then checks only for C. Returns empty value if couldn't find method. =cut sub has_schema { my ($class, $driver) = @_; unless( UNIVERSAL::isa( $driver, 'Jifty::DBI::Handle' ) ) { my $method = 'schema_'. lc $driver; $method = '' unless UNIVERSAL::can( $class, $method ); return $method; } else { my $ver = $driver->database_version; return has_schema( $class, handle_to_driver( $driver ) ) unless $ver; my $method = 'schema_'. lc handle_to_driver( $driver ); $ver =~ s/-.*$//; my @nums = grep $_, map { int($_) } split /\./, $ver; while( @nums ) { my $m = $method ."_". join '_', @nums; return $m if( UNIVERSAL::can( $class, $m ) ); pop @nums; } return has_schema( $class, handle_to_driver( $driver ) ); } } =head2 init_schema Takes C<$class> and C<$handle> or C<$driver> and inits schema by calling method C returns 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 = has_schema( $class, $handle ); diag( "using '$class\:\:$call' schema for ". handle_to_driver( $handle ) ) if $ENV{TEST_VERBOSE}; my $schema = $class->$call(); $schema = ref( $schema )? $schema : [$schema]; my $ret; foreach my $query( @$schema ) { $ret = $handle->simple_query( $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->simple_query( $query ) }; } } =head2 init_data Takes a class to get data from and the handle, calls C method in the class, result is used to create new records of that class. First row is used for columns names. Example: init_data('TestApp::User', $handle); ... package TestApp::User; sub init_data { return ( ['name', 'email'], ['ruz', 'ruz@localhost'], ... ) } =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 => $handle ); my $id = $rec->create( %args ); die "Couldn't create record" unless $id; $count++; } return $count; } =head2 drop_table_if_exists Takes a table name and handle. Drops the table in the DB if it exists. Returns nothing interesting, shouldn't die. =cut sub drop_table_if_exists { my ($table, $handle) = @_; my $d = handle_to_driver( $handle ); if ( $d eq 'Pg' ) { my ($exists) = $handle->dbh->selectrow_array( "select 1 from pg_tables where tablename = ?", undef, $table ); $handle->simple_query("DROP TABLE $table") if $exists; } else { local $@; eval { $handle->simple_query("DROP TABLE IF EXISTS $table") }; } return; } 1; Jifty-DBI-0.77/t/12prefetch.t0000644000175000017500000001671511366355107014554 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 59; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d (@available_drivers) { 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 => $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 $phone = TestApp::Phone->new( handle => $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' ); } my $emp2 = TestApp::Employee->new( handle => $handle ); my $e2_id = $emp2->create( name => 'JESSE' ); my $phone2 = TestApp::Phone->new( handle => $handle ); my $p2_id = $phone2->create( employee => $e2_id, phone => '+16173185823' ); for ( 3 .. 6 ) { my $i = $_; my $phone = TestApp::Phone->new( handle => $handle ); isa_ok( $phone, 'TestApp::Phone' ); my $p_id = $phone->create( employee => $e_id, phone => "+1 $i" ); is( $p_id, $i, "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' ); } $handle->log_sql_statements(1); { # Old prefetch syntax $handle->clear_sql_statement_log; my $collection = TestApp::EmployeeCollection->new( handle => $handle ); $collection->unlimit; my $phones_alias = $collection->join( alias1 => 'main', column1 => 'id', table2 => 'phones', column2 => 'employee' ); $collection->prefetch( $phones_alias => 'phones' ); $collection->order_by( column => 'id' ); is( $collection->count, 2 ); is( scalar( $handle->sql_statement_log ), 1, "count is one statement" ); $handle->clear_sql_statement_log; my $user = $collection->next; is( $user->name, 'RUZ' ); is( $user->id, 1, "got our user" ); my $phones = $user->phones; is( $phones->first->id, 1 ); is( $phones->count, 5 ); my $jesse = $collection->next; is( $jesse->name, 'JESSE' ); my $jphone = $jesse->phones; is( $jphone->count, 1 ); is( scalar( $handle->sql_statement_log ), 1, "all that. just one sql statement" ); } { # New syntax, one-to-many $handle->clear_sql_statement_log; my $collection = TestApp::EmployeeCollection->new( handle => $handle ); $collection->unlimit; $collection->prefetch( name => 'phones' ); is( $collection->count, 2 ); is( scalar( $handle->sql_statement_log ), 1, "count is one statement" ); $handle->clear_sql_statement_log; my $user = $collection->next; is( $user->id, 1, "got our user" ); my $phones = $user->phones; is( $phones->first->id, 1 ); is( $phones->count, 5 ); my $jesse = $collection->next; is( $jesse->name, 'JESSE' ); my $jphone = $jesse->phones; is( $jphone->count, 1 ); is( scalar( $handle->sql_statement_log ), 1, "all that. just one sql statement" ); } { # New syntax, one-to-one $handle->clear_sql_statement_log; my $collection = TestApp::PhoneCollection->new( handle => $handle ); $collection->unlimit; $collection->prefetch( name => 'employee' ); is( $collection->count, 6 ); is( scalar( $handle->sql_statement_log ), 1, "count is one statement" ); $handle->clear_sql_statement_log; my $phone = $collection->next; is( $phone->id, 1, "Got a first phone" ); is( $phone->phone, '+7(903)264-03-51', "Got ruz's phone number" ); my $employee = $phone->employee; is( $employee->id, 1 ); is( $employee->name, "RUZ", "Employee matches" ); is( scalar( $handle->sql_statement_log ), 1, "all that. just one sql statement" ); } cleanup_schema( 'TestApp', $handle ); disconnect_handle($handle); } } # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE table employees ( id integer primary key, name varchar(36) ) }, q{ CREATE table phones ( id integer primary key, employee integer NOT NULL, phone varchar(18) ) } ]; } sub schema_mysql { [ q{ CREATE TEMPORARY table employees ( id integer AUTO_INCREMENT primary key, name varchar(36) ) }, q{ CREATE TEMPORARY table phones ( id integer AUTO_INCREMENT primary key, employee integer NOT NULL, phone varchar(18) ) } ]; } sub schema_pg { [ q{ CREATE TEMPORARY table employees ( id serial PRIMARY KEY, name varchar ) }, q{ CREATE TEMPORARY table phones ( id serial PRIMARY KEY, employee integer references employees(id), phone varchar ) } ]; } package TestApp::PhoneCollection; use base qw/Jifty::DBI::Collection/; sub table { my $self = shift; my $tab = $self->new_item->table(); return $tab; } package TestApp::Employee; use base qw/Jifty::DBI::Record/; sub _value { my $self = shift; my $x = ( $self->__value(@_) ); return $x; } BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column name => type is 'varchar'; column phones => references TestApp::PhoneCollection by 'employee'; } } package TestApp::Phone; use base qw/Jifty::DBI::Record/; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column employee => references TestApp::Employee; column phone => type is 'varchar'; } } package TestApp::EmployeeCollection; use base qw/Jifty::DBI::Collection/; 1; Jifty-DBI-0.77/t/20overload.t0000644000175000017500000004422611547356424014570 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 109; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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::UserCollection->new( handle => $handle ); isa_ok( $users_obj, 'Jifty::DBI::Collection' ); 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->_record_count, 0, '_record_count returns 0 on not limited obj' ); is( $users_obj->count, 0, 'count returns 0 on not limited obj' ); is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after count' ); is( $users_obj->first, undef, 'first returns undef on not limited obj' ); is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after first' ); is( $users_obj->last, undef, 'last returns undef on not limited obj' ); is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after last' ); $users_obj->goto_first_item; is( $users_obj->peek, undef, 'peek returns undef on not limited obj' ); is( <$users_obj>, undef, 'next returns undef on not limited obj' ); is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after next' ); # XXX TODO FIXME: may be this methods should be implemented # $users_obj->goto_last_item; # is( $users_obj->prev, undef, 'prev returns undef on not limited obj' ); my $items_ref = \@$users_obj; isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' ); is_deeply( $items_ref, [], 'items_array_ref 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, 'Jifty::DBI::Record', 'first returns record object' ); isa_ok( $users_obj->last, 'Jifty::DBI::Record', 'last returns record object' ); $users_obj->goto_first_item; isa_ok( $users_obj->peek, 'Jifty::DBI::Record', 'peek returns record object' ); isa_ok( <$users_obj>, 'Jifty::DBI::Record', 'next returns record object' ); $items_ref = \@$users_obj; isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' ); is( scalar @{$items_ref}, $count_all, 'items_array_ref returns same number of records as was inserted' ); $users_obj->redo_search; $items_ref = \@$users_obj; isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' ); is( scalar @{$items_ref}, $count_all, 'items_array_ref returns same number of records as was inserted' ); # try to use $users_obj for all tests, after each call to clean_slate it should look like new obj. # and test $obj->new syntax my $clean_obj = $users_obj->new( handle => $handle ); isa_ok( $clean_obj, 'Jifty::DBI::Collection' ); # basic limits $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'login', value => 'obra' ); is( $users_obj->count, 1, 'found one user with login obra' ); TODO: { local $TODO = 'require discussion'; is( $users_obj->is_last, undef, 'is_last returns undef before we fetch any record' ); } my $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $users_obj->is_last, 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->is_last, 1, 'is_last always returns 1 after last call'); $users_obj->goto_first_item; my $peek_rec = $users_obj->peek; my $next_rec = <$users_obj>; is( $next_rec, $peek_rec, 'peek returns same object as next' ); is( $next_rec, $first_rec, 'next returns same object as first' ); is( $users_obj->is_last, 1, 'is_last returns 1 after fetch first record with next method'); is( $users_obj->peek, undef, 'only one record in the collection' ); is( <$users_obj>, undef, 'only one record in the collection' ); TODO: { local $TODO = 'require discussion'; is( $users_obj->is_last, undef, 'next returns undef, is_last returns undef too'); } $items_ref = \@$users_obj; isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' ); is( scalar @{$items_ref}, 1, 'items_array_ref has only 1 record' ); # similar basic limit, but with different operators and less first/next/last tests # LIKE $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'Glass' ); is( $users_obj->count, 1, "found one user with 'Glass' in the name" ); $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'glasser', 'login is correct' ); # LIKE with wildcard $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'G_ass' ); is( $users_obj->count, 1, "found one user with 'Glass' in the name" ); $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'glasser', 'login is correct' ); # LIKE with escaped wildcard $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); # XXX: don't use backslashes; Pg (only Pg?) requires special # treatment like "LIKE E'%g\\_ass%'" for that case, # which is not supported yet (but this should be fixed) $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'G@_ass', escape => '@' ); is( $users_obj->count, 0, "should not find users with 'Glass' in the name" ); # LIKE with wildcard $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'Glass%' ); is( $users_obj->count, 1, "found one user with 'Glass' in the name" ); $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'glasser', 'login is correct' ); # MATCHES with escaped wildcard $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); # XXX: don't use backslashes; reason above $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'Glass@%', escape => '@' ); is( $users_obj->count, 0, "should not find users with 'Glass' in the name" ); # STARTSWITH $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => '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, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'cubic', 'login is correct' ); # ENDSWITH $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => '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, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'audreyt', 'login is correct' ); # IN $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'login', operator => 'IN', value => ['cubic', 'obra', 'glasser', 'audreyt'] ); is( $users_obj->count, 4, "found 4 user ids" ); my %logins = (cubic => 1, obra => 1, glasser => 1, audreyt => 1); while ( my $user = <$users_obj> ) { is ( defined $logins{$user->login}, 1, 'Found login' ); delete $logins{$user->login}; } is ( scalar( keys( %logins ) ), 0, 'All logins found' ); # IS NULL # XXX TODO FIXME: column => undef should be handled as NULL $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'phone', operator => 'IS', value => 'NULL' ); is( $users_obj->count, 2, "found 2 users who has unknown phone number" ); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'address', operator => 'IS', value => 'NULL' ); is( $users_obj->count, 0, "found 0 users who has unknown address" ); # IS NOT NULL $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'phone', operator => 'IS NOT', value => 'NULL', quotevalue => 0 ); is( $users_obj->count, $count_all - 2, "found users who have phone number filled" ); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'address', operator => 'IS NOT', value => 'NULL', quotevalue => 0 ); is( $users_obj->count, $count_all, "found users who have address filled" ); # CASE SENSITIVITY, default is limits are not case sensitive $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => 'Jesse Vincent' ); is( $users_obj->count, 1, "case insensitive, matching case, should find one row"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => 'jesse vincent' ); is( $users_obj->count, 1, "case insensitive, non-matched case, should find one row"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => ['Jesse Vincent', 'Audrey Tang'], operator => 'IN'); is( $users_obj->count, 2, "case insensitive, matching case, should find two rows"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => ['jesse vincent', 'audrey tang'], operator => 'IN'); is( $users_obj->count, 2, "case insensitive, non-matched case, should find two rows"); # CASE SENSITIVITY, testing with case_sensitive => 1 $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => 'Jesse Vincent', case_sensitive => 1 ); is( $users_obj->count, 1, "case sensitive search, should find one row"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => 'jesse vincent', case_sensitive => 1 ); TODO: { local $TODO = "MySQL still needs case sensitive fixes" if ( $d eq 'mysql' || $d eq 'mysqlPP' ); is( $users_obj->count, 0, "case sensitive search, should find zero rows"); } $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => ['Jesse Vincent', 'Audrey Tang'], operator => 'IN', case_sensitive => 1 ); is( $users_obj->count, 2, "case sensitive search, should find two rows"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => ['jesse vincent', 'audrey tang'], operator => 'IN', case_sensitive => 1 ); TODO: { local $TODO = "MySQL still needs case sensitive fixes" if ( $d eq 'mysql' || $d eq 'mysqlPP' ); is( $users_obj->count, 0, "case sensitive search, should find zero rows"); } # ORDER BY / GROUP BY $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->unlimit; $users_obj->group_by(column => 'login'); $users_obj->order_by(column => 'login', order => 'desc'); $users_obj->column(column => 'login'); is( $users_obj->count, $count_all, "group by / order by finds right amount"); $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'obra', 'login is correct' ); $users_obj->clean_slate; TODO: { local $TODO = 'we leave order_by after clean slate, fixing this results in many RT failures'; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj = TestApp::UserCollection->new( handle => $handle ); } # Let's play a little with 'entry_aggregator' # EA defaults to OR for the same field $users_obj->limit( column => 'phone', operator => 'IS', value => 'NULL', quote_value => 0 ); $users_obj->limit( column => '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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'Login', operator => 'NOT LIKE', value => '%c%' ); $users_obj->limit( entry_aggregator => 'AND', column => '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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'phone', operator => 'IS', value => 'NULL', quote_value => 0 ); $users_obj->limit( column => 'login', operator => 'LIKE', value => '%r%' ); is( $users_obj->count, 2, "found users who has no phone number or login has 'r' char" ); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql { <table('users'); $self->SUPER::_init(@_); } sub init_data { return ( [ 'login', 'name', 'phone', 'address' ], [ 'cubic', 'Ruslan U. Zakirov', '+7-903-264-XX-XX', undef ], [ 'obra', 'Jesse Vincent', undef, undef ], [ 'glasser', 'David Glasser', undef, 'somewhere' ], [ 'audreyt', 'Audrey Tang', '+X-XXX-XXX-XX-XX', 'someplace' ], ); } 1; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column login => type is 'varchar(18)'; column name => type is 'varchar(36)'; column phone => type is 'varchar(18)', default is undef; column address => type is 'varchar(18)', default is ''; } } 1; package TestApp::UserCollection; # use TestApp::User; use base qw/Jifty::DBI::Collection/; sub _init { my $self = shift; $self->SUPER::_init(@_); $self->table('users'); } 1; Jifty-DBI-0.77/t/01basics.t0000644000175000017500000000076511305565770014216 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 4; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { SKIP: { use_ok('Jifty::DBI::Handle::'. $d); my $handle = get_handle( $d ); isa_ok($handle, 'Jifty::DBI::Handle'); isa_ok($handle, 'Jifty::DBI::Handle::'. $d); can_ok($handle, 'dbh'); } } 1; Jifty-DBI-0.77/t/02searches_joins.t0000644000175000017500000002647411305565770015757 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 47; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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::UserToGroup', $handle ); ok( $count_us2gs, "init users&groups relations data" ); my $clean_obj = TestApp::UserCollection->new( handle => $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->_is_joined, "new object isn't joined"); my $alias = $users_obj->join( column1 => 'id', table2 => 'user_to_groups', column2 => 'user_id' ); 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( column => '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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); ok( !$users_obj->_is_joined, "new object isn't joined"); my $alias = $users_obj->join( type => 'LEFT', column1 => 'id', table2 => 'user_to_groups', column2 => 'user_id' ); ok( $alias, "Join returns alias" ); $users_obj->limit( alias => $alias, column => 'id', operator => 'IS', value => 'NULL' ); ok( $users_obj->build_select_query =~ /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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); ok( !$users_obj->_is_joined, "new object isn't joined"); my $alias = $users_obj->join( type => 'LEFT', column1 => 'id', table2 => 'user_to_groups', column2 => 'user_id' ); ok( $alias, "Join returns alias" ); $users_obj->limit( alias => $alias, column => 'id', operator => 'IS NOT', value => 'NULL' ); if ( $d eq 'mysql' && $handle->database_version =~ /^[34]/ ) { ok( $users_obj->build_select_query !~ /LEFT JOIN/, 'LJ is optimized away'); } else { ok( 1, 'mysql >= 5.0 dont need this optimization' ); } 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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); ok( !$users_obj->_is_joined, "new object isn't joined"); my $alias = $users_obj->new_alias( 'user_to_groups' ); ok( $alias, "new alias" ); is($users_obj->join( type => 'LEFT', column1 => 'id', alias2 => $alias, column2 => 'user_id' ), $alias, "joined table" ); $users_obj->limit( alias => $alias, column => 'id', operator => 'IS', value => 'NULL' ); ok( $users_obj->build_select_query =~ /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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); ok( !$users_obj->_is_joined, "new object isn't joined"); my $alias = $users_obj->new_alias( 'user_to_groups' ); ok( $alias, "new alias" ); ok( $users_obj->_is_joined, "object with aliases is joined"); $users_obj->limit( column => 'id', value => "$alias.user_id", quote_value => 0); ok( my $groups_alias = $users_obj->join( alias1 => $alias, column1 => 'group_id', table2 => 'groups', column2 => 'id', ), "joined table" ); $users_obj->limit( alias => $groups_alias, column => 'name', value => 'Developers' ); #diag $users_obj->build_select_query; 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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); ok( !$users_obj->_is_joined, "new object isn't joined"); ok( my $groups_alias = $users_obj->new_alias( 'groups' ), "new alias" ); ok( my $g2u_alias = $users_obj->join( alias1 => 'main', column1 => 'id', table2 => 'user_to_groups', column2 => 'user_id', ), "joined table" ); $users_obj->limit( alias => $g2u_alias, column => 'group_id', value => "$groups_alias.id", quote_value => 0); $users_obj->limit( alias => $groups_alias, column => 'name', value => 'Developers' ); #diag $users_obj->build_select_query; is( $users_obj->count, 3, "three members" ); } diag "cascaded LEFT JOIN optimization" if $ENV{'TEST_VERBOSE'}; { $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); ok( !$users_obj->_is_joined, "new object isn't joined"); my $alias = $users_obj->join( type => 'LEFT', column1 => 'id', table2 => 'user_to_groups', column2 => 'user_id' ); ok( $alias, "Join returns alias" ); $alias = $users_obj->join( type => 'LEFT', alias1 => $alias, column1 => 'group_id', table2 => 'groups', column2 => 'id' ); $users_obj->limit( alias => $alias, column => 'id', operator => 'IS NOT', value => 'NULL' ); if ( $d eq 'mysql' && $handle->database_version =~ /^[34]/ ) { ok( $users_obj->build_select_query !~ /LEFT JOIN/, 'both LJs are optimized away'); } else { ok( 1, 'mysql >= 5.0 dont need this optimization' ); } 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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); ok( !$users_obj->_is_joined, "new object isn't joined"); my $alias = $users_obj->join( type => 'LEFT', column1 => 'id', table2 => 'user_to_groups', column2 => 'user_id' ); $users_obj->open_paren('my_clause'); $users_obj->limit( subclause => 'my_clause', alias => $alias, column => 'id', operator => 'IS NOT', value => 'NULL' ); $users_obj->limit( subclause => 'my_clause', entry_aggregator => 'OR', column => 'id', value => 3 ); $users_obj->close_paren('my_clause'); ok( $users_obj->build_select_query =~ /LEFT JOIN/, 'LJ is not optimized away'); is( $users_obj->count, 4, "all users" ); } 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 user_to_groups ( id integer primary key, user_id integer, group_id 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 user_to_groups ( id integer primary key AUTO_INCREMENT, user_id integer, group_id 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 user_to_groups ( id serial primary key, user_id integer, group_id 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 user_to_groups_seq", "CREATE table user_to_groups ( id integer CONSTRAINT user_to_groups_Key PRIMARY KEY, user_id integer, group_id 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 user_to_groups_seq", "DROP table user_to_groups", ] } package TestApp::User; use base qw/Jifty::DBI::Record/; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column login => type is 'varchar(36)'; }; } sub _init { my $self = shift; $self->table('users'); $self->SUPER::_init( @_ ); } sub init_data { return ( [ 'login' ], [ 'ivan' ], [ 'john' ], [ 'bob' ], [ 'aurelia' ], ); } package TestApp::UserCollection; use base qw/Jifty::DBI::Collection/; sub _init { my $self = shift; $self->table('users'); return $self->SUPER::_init( @_ ); } 1; package TestApp::Group; use base qw/Jifty::DBI::Record/; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column name => type is 'varchar(36)'; }; } sub _init { my $self = shift; $self->table('groups'); return $self->SUPER::_init( @_ ); } sub init_data { return ( [ 'name' ], [ 'Developers' ], [ 'Sales' ], [ 'Support' ], ); } package TestApp::GroupCollection; use base qw/Jifty::DBI::Collection/; sub _init { my $self = shift; $self->table('groups'); return $self->SUPER::_init( @_ ); } 1; package TestApp::UserToGroup; use base qw/Jifty::DBI::Record/; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column user_id => type is 'int(11)'; column group_id => type is 'int(11)'; }; } sub init_data { return ( [ 'group_id', 'user_id' ], # dev group [ 1, 1 ], [ 1, 2 ], [ 1, 4 ], # sales # [ 2, 0 ], # support [ 3, 1 ], ); } package TestApp::UserToGroupCollection; use base qw/Jifty::DBI::Collection/; 1; Jifty-DBI-0.77/t/01-version_checks.t0000644000175000017500000000240411305565770016024 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More qw(no_plan); # by Eric Wilhelm in response to Randal Schwartz pointing out that # CPAN.pm chokes on the VERSION >... construct # I dare not mention it here. use ExtUtils::MakeMaker; use ExtUtils::Manifest qw(maniread); use_ok('Jifty::DBI'); my $minfo = maniread(); ok($minfo) or die; # XXX crossing my fingers against cross-platform and/or chdir issues my @files = grep(/\.pm$/, grep(/^lib/, keys(%$minfo))); ok(scalar(@files)); # die join "\n", '', @files, ''; foreach my $file (@files) { # Gah! parse_version complains on stderr! my ($e, @a) = error_catch(sub {MM->parse_version($file)}); ok(($e || '') eq '', $file) or warn "$e "; } # runs subroutine reference, looking for error message $look in STDERR # and runs tests based on $name # ($errs, @ans) = error_catch(sub {$this->test()}); # sub error_catch { my ($sub) = @_; my $TO_ERR; open($TO_ERR, '<&STDERR'); close(STDERR); my $catch; open(STDERR, '>', \$catch); my @ans = $sub->(); open(STDERR, ">&", $TO_ERR); close($TO_ERR); return($catch, @ans); } # end subroutine error_catch definition ######################################################################## Jifty-DBI-0.77/t/case_sensitivity.t0000644000175000017500000001257011366355107016171 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 139; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; use DateTime (); foreach my $d (@available_drivers) { SKIP: { unless ( has_schema( 'TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle($d); connect_handle($handle); isa_ok( $handle->dbh, 'DBI::db' ); { my $ret = init_schema( 'TestApp::User', $handle ); isa_ok( $ret, 'DBI::st', "Inserted the schema. got a statement handle back" ); } my $rec = TestApp::User->new( handle => $handle ); isa_ok( $rec, 'Jifty::DBI::Record' ); my ($id) = $rec->create( name => 'Foobar', interests => 'Slacking' ); ok( $id, "Successfuly created ticket" ); $rec->load_by_cols( name => 'foobar' ); TODO: { local $TODO = "How do we force mysql to be case sensitive?" if ( $d eq 'mysql' || $d eq 'mysqlPP' ); is( $rec->id, undef ); } $rec->load_by_cols( name => { value => 'foobar', case_sensitive => 0, operator => '=' } ); is( $rec->id, $id ); $rec->load_by_cols( name => 'Foobar' ); is( $rec->id, $id ); $rec->load_by_cols( interests => 'slacking' ); is( $rec->id, $id ); $rec->load_by_cols( interests => 'Slacking' ); is( $rec->id, $id ); # IN # IS # IS NOT ### Numbers threeway_same($handle, id => $_, 42) for qw/= != < > <= >=/; threeway_same($handle, id => $_, 42) for ("LIKE", "NOT LIKE", "MATCHES", "STARTS_WITH", "ENDS_WITH"); threeway_same($handle, id => $_ => [ 42, 17 ]) for qw/= IN/; threeway_same($handle, id => $_ => 'NULL') for ("IS", "IS NOT"); threeway_same($handle, id => $_ => 'null') for ("IS", "IS NOT"); ## Strings threeway_same($handle, name => $_, "bob") for qw/< > <= >=/; threeway_same($handle, name => $_, 17) for ("=", "!=", "LIKE", "NOT LIKE"); threeway_different($handle, name => $_, 17) for ("MATCHES", "STARTS_WITH", "ENDS_WITH"); threeway_different($handle, name => $_, "bob") for ("=", "!=", "LIKE", "NOT LIKE", "MATCHES", "STARTS_WITH", "ENDS_WITH"); threeway_different($handle, name => $_, "null") for ("=", "!=", "LIKE", "NOT LIKE", "MATCHES", "STARTS_WITH", "ENDS_WITH"); threeway_different($handle, name => $_ => [ "bob", "alice" ]) for qw/= IN/; threeway_same($handle, name => $_ => 'NULL') for ("IS", "IS NOT"); threeway_same($handle, name => $_ => 'null') for ("IS", "IS NOT"); ## Other threeway_same($handle, created => $_, 42) for qw/= != < > <= >=/; threeway_same($handle, created => $_, 42) for ("LIKE", "NOT LIKE", "MATCHES", "STARTS_WITH", "ENDS_WITH"); threeway_same($handle, created => $_ => [ 42, 17 ]) for qw/= IN/; threeway_same($handle, created => $_ => 'NULL') for ("IS", "IS NOT"); threeway_same($handle, created => $_ => 'null') for ("IS", "IS NOT"); cleanup_schema( 'TestApp', $handle ); disconnect_handle($handle); } } sub threeway_same { my ($default, $insensitive, $sensitive) = threeway_test(@_); shift @_; is( $default, $insensitive, "Default and insensitive queries are the same (@_)"); is( $sensitive, $insensitive, "Sensitive and insensitive queries are the same (@_)"); } sub threeway_different { my ($default, $insensitive, $sensitive) = threeway_test(@_); my $handle = shift @_; is( $default, $sensitive, "Default and insensitive queries are the same (@_)"); TODO: { local $TODO = "How do we force mysql to be case sensitive?" if $handle =~ /mysql/; isnt( $sensitive, $insensitive, "Sensitive and insensitive queries are not the same (@_)"); } } sub threeway_test { my ($handle, $column, $op, $value) = @_; my $default = TestApp::UserCollection->new( handle => $handle ); $default->limit( column => $column, value => $value, operator => $op ); my $insensitive = TestApp::UserCollection->new( handle => $handle ); $insensitive->limit( column => $column, value => $value, operator => $op, case_sensitive => 0 ); my $sensitive = TestApp::UserCollection->new( handle => $handle ); $sensitive->limit( column => $column, value => $value, operator => $op, case_sensitive => 1 ); return map {$_->build_select_query} ($default, $insensitive, $sensitive); } package TestApp::User; use base qw/Jifty::DBI::Record/; sub schema_sqlite { < type is 'varchar', label is 'Name', is case_sensitive; column interests => type is 'varchar'; column created => type is 'date'; }; package TestApp::UserCollection; use base qw/Jifty::DBI::Collection/; 1; Jifty-DBI-0.77/t/06filter_storable.t0000644000175000017500000000372611305565770016137 0ustar chmrrchmrr#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 9; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; my $complex_data = { foo => 'bar', baz => [ 1, 2, 3 ], }; foreach my $d (@available_drivers) { SKIP: { unless (has_schema('TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle($d); connect_handle($handle); isa_ok($handle->dbh, 'DBI::db'); { my $ret = init_schema('TestApp::User', $handle); isa_ok($ret, 'DBI::st', 'init schema'); } my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my ($id) = $rec->create( my_data => $complex_data ); ok($id, 'created record'); ok($rec->load($id), 'loaded record'); is($rec->id, $id, 'record id matches'); is(ref $rec->my_data, 'HASH', 'my_data is a HASH'); is_deeply($rec->my_data, $complex_data, 'my_data matches initial data'); # undef/NULL $rec->set_my_data; is($rec->my_data, undef, 'set undef value'); cleanup_schema('TestApp', $handle); disconnect_handle($handle); } } package TestApp::User; use base qw/ Jifty::DBI::Record /; 1; sub schema_sqlite { < type is 'blob', filters are qw/ Jifty::DBI::Filter::Storable /; } } Jifty-DBI-0.77/t/05raw_value.t0000644000175000017500000000515011547413324014727 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); eval "use URI"; plan skip_all => "URI required for testing the URI filter" if $@; use constant TESTS_PER_DRIVER => 14; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; use DateTime (); foreach my $d ( @available_drivers ) { SKIP: { unless( has_schema( 'TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); {my $ret = init_schema( 'TestApp::User', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); require URI; my $uri = URI->new( 'http://bestpractical.com/foo' ); my ($id) = $rec->create(uri => $uri); ok($id, "Successfuly created a user"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); isa_ok( $rec->uri, 'URI' ); is($rec->uri->as_string, $uri, "Corrent uri"); is($rec->__raw_value( 'uri' ), $uri->as_string, 'Correct raw uri' ); # undef/NULL $rec->set_uri; is($rec->uri, undef, "Set undef value" ); is($rec->__raw_value( 'uri' ), undef, 'Correct raw uri' ); my $new_uri = 'http://jifty.org/bar'; $rec->set_uri( $new_uri ); isa_ok( $rec->uri, 'URI' ); is($rec->uri->as_string, $new_uri, "The record has its id"); is($rec->__raw_value( 'uri' ), $new_uri, 'Correct raw value' ); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); } } package TestApp::User; use base qw/Jifty::DBI::Record/; 1; sub schema_sqlite { < type is 'text', filters are qw/Jifty::DBI::Filter::URI/, default is undef; } } 1; Jifty-DBI-0.77/t/17virtualtypes.t0000644000175000017500000000532411305565770015530 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 9; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { SKIP: { unless( has_schema( 'TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); {my $ret = init_schema( 'TestApp::User', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my ($id) = $rec->create( location_x => 10, location_y => 20 ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); is($rec->location_x, 10); is($rec->location_y, 20); is_deeply($rec->location, { x => 10, y => 20}); disconnect_handle($handle); } } package TestApp::User; use base qw/Jifty::DBI::Record/; 1; sub schema_sqlite { <name; $column->virtual(1); for (qw(x y)) { Jifty::DBI::Schema::_init_column_for( Jifty::DBI::Column->new({ type => 'double', name => $name."_$_", writable => $column->writable, readable => $column->readable }), $from); } no strict 'refs'; *{$from.'::'.$name} = sub { return { map { my $method = "${name}_$_"; $_ => $_[0]->$method } qw(x y) } }; *{$from.'::'.'set_'.$name} = sub { die "not yet" }; } BEGIN { use Jifty::DBI::Schema; Jifty::DBI::Schema->register_types( GeoLocation => sub { _init_handler is \&geolocation }, ); } use Jifty::DBI::Record schema { column location => is GeoLocation; }; 1; Jifty-DBI-0.77/t/99-pod-spelling.t0000644000175000017500000000216611566506177015447 0ustar chmrrchmrruse strict; use warnings; use Test::More; BEGIN { plan skip_all => "Spelling tests only run for authors" unless -d 'inc/.author'; } eval "use Test::Spelling 0.12"; plan skip_all => "Test::Spelling 0.12 required for testing POD spelling" if $@; add_stopwords(); all_pod_files_spelling_ok(); __DATA__ Autocommit autocompleted backend BYTEA canonicalizer canonicalizers Checkbox classdata COLUMNNAME Combobox cpan database's datasource DateTime DBD dbh DBI deserialize dsn formatter Glasser Hanenkamp hashrefs HookResults Informix Informix's InlineButton Jifty Knopp LLC login lookups lossy marshalling memcached metadata mhat mixin mixins MyModel myscript mysql's NULLs ODBC OtherClass OtherCollection paramhash Postgres postgres PostgreSQL prefetch prefetched prefetches preload prepends PrintError QUERYSTRING RaiseError recordset RequireSSL requiressl resultsets Ruslan SchemaGenerator SearchBuilder sid Spier SQL SQLite SQLite's STATEMENTREF STDERR Storable Sybase Sybase's Syck TABLENAME Tappe TODO unimported unlimit unmarshalling Unrendered username UTC UTF utf validator validators Vandiver wildcard YAML Zakirov Jifty-DBI-0.77/t/99-tabs.t0000644000175000017500000000035211547413324013764 0ustar chmrrchmrruse Test::More; plan skip_all => "Tab tests only run for authors" unless (-d 'inc/.author'); eval "use Test::NoTabs 1.00"; plan skip_all => "Test::NoTabs 1.00 required for testing POD coverage" if $@; all_perl_files_ok('lib', 't'); Jifty-DBI-0.77/t/18triggers.t0000644000175000017500000001312411547413324014574 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 66; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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 => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my $rid = $rec->create( name => 'Sterling', phone => '123 456 7890', ); ok($rid, 'created a record'); $rec->load($rid); ok($rec->id, 'loaded a record'); $rec->set_name('zostay'); $rec->set_phone('098 765 4321'); my $ret = $rec->delete; ok($ret, 'deleted a record'); disconnect_handle($handle); }; } package TestApp::TestMixin; use base qw/ Jifty::DBI::Record::Plugin /; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { }; use Test::More; sub register_triggers { my $self = shift; $self->add_trigger(before_create => sub { my $self = shift; my $columns = shift; isa_ok($self, 'TestApp::Address'); is(ref $columns, 'HASH', 'arg is a hash'); is(scalar(keys %$columns), 2, 'arg has 2 keys'); is($columns->{name}, 'Sterling', 'name is Sterling'); is($columns->{phone}, '123 456 7890', 'phone is 123 456 7890'); }); $self->add_trigger(after_create => sub { my $self = shift; my $ret = shift; isa_ok($self, 'TestApp::Address'); is(ref $ret, 'SCALAR', 'arg is a scalar ref'); ok($$ret, 'create was sucessful'); }); $self->add_trigger(before_set => sub { my $self = shift; my $arg = shift; isa_ok($self, 'TestApp::Address'); is(ref $arg, 'HASH', 'arg is a hash'); is(scalar(keys %$arg), 3, 'hash has 2 keys'); ok($arg->{column}, "column arg is set"); ok($arg->{value}, "value arg set"); is($arg->{is_sql_function}, undef, 'is_sql_function is undef'); }); $self->add_trigger(after_set => sub { my $self = shift; my $arg = shift; isa_ok($self, 'TestApp::Address'); is(ref $arg, 'HASH', 'arg is a hash'); is(scalar(keys %$arg), 3, 'hash has 3 keys'); ok($arg->{column}, "column arg is set"); ok($arg->{value}, "value arg is set"); ok($arg->{old_value}, "old_value arg is set"); }); $self->add_trigger(before_delete => sub { my $self = shift; isa_ok($self, 'TestApp::Address'); }); $self->add_trigger(after_delete => sub { my $self = shift; my $ret = shift; isa_ok($self, 'TestApp::Address'); is(ref $ret, 'SCALAR', 'arg is a scalar ref'); ok($$ret, 'delete was successful'); }); } sub register_triggers_for_column { my $self = shift; my $column = shift; my $old_value = $column eq 'name' ? 'Sterling' : '123 456 7890'; my $value = $column eq 'name' ? 'zostay' : '098 765 4321'; $self->add_trigger('before_set_'.$column => sub { my $self = shift; my $arg = shift; isa_ok($self, 'TestApp::Address'); is(ref $arg, 'HASH', 'arg is a hash'); is(scalar(keys %$arg), 3, 'hash has 2 keys'); is($arg->{column}, $column, "column arg is $column"); is($arg->{value}, $value, "value arg is $value"); is($arg->{is_sql_function}, undef, 'is_sql_function is undef'); }); $self->add_trigger('after_set_'.$column => sub { my $self = shift; my $arg = shift; isa_ok($self, 'TestApp::Address'); is(ref $arg, 'HASH', 'arg is a hash'); is(scalar(keys %$arg), 3, 'hash has 3 keys'); is($arg->{column}, $column, "column arg is $column"); is($arg->{value}, $value, "value arg is $value"); is($arg->{old_value}, $old_value, "old_value arg is $old_value"); }); } 1; package TestApp::Address; use base qw/ Jifty::DBI::Record /; sub schema_mysql { < till 999, type is 'varchar(14)'; column phone => type is 'varchar(18)'; column address => type is 'varchar(50)', default is ''; column employee_id => type is 'int(8)'; }; TestApp::TestMixin->import(); } 1; Jifty-DBI-0.77/t/02records_object.t0000644000175000017500000000641111305565770015734 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 9; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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 => $handle ); my $e_id = $emp->create( name => 'RUZ' ); ok($e_id, "Got an id for the new emplyee"); my $phone = TestApp::Phone->new( handle => $handle ); isa_ok( $phone, 'TestApp::Phone', "it's a TestApp::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->employee(); ok($obj, "Employee #$e_id has phone #$p_id"); isa_ok( $obj, 'TestApp::Employee'); is($obj->id, $e_id); is($obj->name, 'RUZ'); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $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; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column name => type is 'varchar(18)'; } } 1; package TestApp::Phone; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column employee => references TestApp::Employee; column phone => type is 'varchar(18)'; } } 1; Jifty-DBI-0.77/t/06filter.t0000644000175000017500000000137611305565770014243 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } plan tests => 7; # test for Jifty::DBI::Filter class only # create new t/06filter_*.t files for specific filters # DB independat tests use_ok('Jifty::DBI::Filter'); my $filter = new Jifty::DBI::Filter; isa_ok( $filter, 'Jifty::DBI::Filter' ); is( $filter->column, undef, "empty column value" ); is( $filter->value_ref, undef, "empty value reference" ); is( $filter->handle, undef, "empty handle" ); $filter->column( 'my column' ); is( $filter->column, 'my column', "successfuly set column" ); $filter->value_ref( 'my value_ref' ); is( $filter->value_ref, 'my value_ref', "successfuly set value_ref" ); # methods do nothing, but just in case $filter->decode; $filter->encode; 1; Jifty-DBI-0.77/t/03rename_column.t0000644000175000017500000000354611305565770015600 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; use Jifty::DBI::Handle; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 11; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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' ); drop_table_if_exists( 'test', $handle ); my $sth = $handle->simple_query( "CREATE TABLE test (a int, x integer not null default 1)" ); ok $sth, 'created a table'; ok $handle->simple_query("insert into test values(2,2)"), "inserted a record"; $sth = $handle->simple_query("select * from test"); is $sth->fetchrow_hashref->{'x'}, 2, 'correct value'; $handle->rename_column( table => 'test', column => 'x', to => 'y' ); $sth = $handle->simple_query("select * from test"); is $sth->fetchrow_hashref->{'y'}, 2, 'correct value'; $sth->finish; undef $sth; my @warnings; ok !eval { local $SIG{__WARN__} = sub { push @warnings, @_ }; $handle->simple_query("insert into test(x) values(1)"); }, "no x anymore"; ok((splice @warnings), "we got warnings"); ok !eval { local $SIG{__WARN__} = sub { push @warnings, @_ }; $handle->simple_query("insert into test(y) values(NULL)"); }, "NOT NULL is still there"; ok((splice @warnings), "we got warnings"); $handle->simple_query("delete from test"); ok $handle->simple_query("insert into test(a) values(1)"), "DEFAULT is still there"; is $handle->simple_query("select * from test")->fetchrow_hashref->{'y'}, 1, 'correct value'; undef $handle; }} # SKIP, foreach blocks 1; Jifty-DBI-0.77/t/11schema_records.t0000644000175000017500000002041611375011517015717 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 68; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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 => $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); is($emp->pid, $$); my $phone_collection = $emp->phones; isa_ok($phone_collection, 'TestApp::PhoneCollection'); { my ($val, $msg); eval { ($val, $msg) = $emp->set_phones(1,2,3); }; ok(not($@), 'set does not die') or warn $@; ok($@ !~ /^DBD::.*::st execute failed: /, "no stacktrace emitted" ); ok(! $val, $msg) or warn "msg: $msg"; ok($msg =~ m/Collection column '.*' not writable/, '"not writable" message' ); } { my $ph = $phone_collection->next; is($ph, undef, "No phones yet"); } my $phone = TestApp::Phone->new( handle => $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->redo_search; 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 => $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->redo_search; 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->set_employee($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->redo_search; is($phone_collection->next, undef, "first emp lost phone"); } { $phone2_collection->redo_search; 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->set_employee($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->redo_search; is($phone2_collection->next, undef, "second emp lost phone"); } { $phone_collection->redo_search; 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 => $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->redo_search; 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 => $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->redo_search; my $ph = $phone_collection->next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p_id, 'still has this phone'); is($ph->phone, '+7(903)264-03-51'); $ph = $phone_collection->next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p2_id, 'still has that phone'); is($ph->phone, '123456'); $ph = $phone_collection->next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p3_id, 'even has this other phone'); is($ph->phone, '7890'); is($phone_collection->next, undef); } cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE table employees ( id integer primary key, name varchar(36) ) }, q{ CREATE table phones ( id integer primary key, employee integer NOT NULL, phone varchar(18) ) } ] } sub schema_mysql { [ q{ CREATE TEMPORARY table employees ( id integer AUTO_INCREMENT primary key, name varchar(36) ) }, q{ CREATE TEMPORARY table phones ( id integer AUTO_INCREMENT primary key, employee integer NOT NULL, phone varchar(18) ) } ] } sub schema_pg { [ q{ CREATE TEMPORARY table employees ( id serial PRIMARY KEY, name varchar ) }, q{ CREATE TEMPORARY table phones ( id serial PRIMARY KEY, employee integer references employees(id), phone varchar ) } ] } package TestApp::PhoneCollection; use base qw/Jifty::DBI::Collection/; sub table { my $self = shift; my $tab = $self->new_item->table(); return $tab; } package TestApp::Employee; use base qw/Jifty::DBI::Record/; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column name => type is 'varchar'; column phones => references TestApp::PhoneCollection by 'employee'; column pid => is computed; }; sub pid { $$ } } sub _value { my $self = shift; my $x = ($self->__value(@_)); return $x; } package TestApp::Phone; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema {; column employee => refers_to TestApp::Employee; # "refers_to" is the old synonym to "references" column phone => type is 'varchar'; } } 1; Jifty-DBI-0.77/t/06filter_base64.t0000644000175000017500000000461011417767664015413 0ustar chmrrchmrr#!/usr/bin/env perl use strict; use warnings; use Encode qw(decode_utf8 is_utf8); use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 20; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; my $normal_data = "Hi there"; my $perl_data = "Hi there—"; my $utf8_data = decode_utf8($perl_data); foreach my $d (@available_drivers) { SKIP: { unless (has_schema('TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle($d); connect_handle($handle); isa_ok($handle->dbh, 'DBI::db'); { my $ret = init_schema('TestApp::User', $handle); isa_ok($ret, 'DBI::st', 'init schema'); } # data ref, is_utf8 expected, base64 expected, handle store_data( \$normal_data, 0, "SGkgdGhlcmU=\n", $handle ); store_data( \$perl_data, 0, "SGkgdGhlcmXigJQ=\n", $handle ); store_data( \$utf8_data, 1, "SGkgdGhlcmXigJQ=\n", $handle ); cleanup_schema('TestApp', $handle); disconnect_handle($handle); } } sub store_data { my $data = shift; my $isutf8 = shift; my $expected = shift; my $handle = shift; my $utf8 = is_utf8($$data) ? 1 : 0; ok $utf8 == $isutf8, "is_utf8 = $utf8 as expected"; my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my $id; eval { $id = $rec->create( content => $$data ); }; ok($id, 'created record'); ok($rec->load($id), 'loaded record'); is($rec->id, $id, 'record id matches'); is($rec->__raw_value('content'), $expected, "got expected base64"); } package TestApp::User; use base qw/ Jifty::DBI::Record /; 1; sub schema_sqlite { < type is 'text', filters are qw/ Jifty::DBI::Filter::base64 /; } } Jifty-DBI-0.77/t/06filter_datetime.t0000644000175000017500000000667511305565770016126 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 18; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; use DateTime (); foreach my $d ( @available_drivers ) { SKIP: { unless( has_schema( 'TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); {my $ret = init_schema( 'TestApp::User', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my $now = time; my $today = DateTime->from_epoch( epoch => $now )->truncate( to => 'day' )->epoch; my $min_of_day = DateTime->from_epoch( epoch => $now )->truncate( to => 'minute' ); my $dt = DateTime->from_epoch( epoch => $now ); my ($id) = $rec->create( created => $dt, event_on => $dt, event_stops => $min_of_day ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); isa_ok($rec->created, 'DateTime' ); is( $rec->created->epoch, $now, "Correct value"); isa_ok($rec->event_on, 'DateTime' ); is( $rec->event_on->epoch, $today, "Correct value"); isa_ok($rec->event_stops, 'DateTime' ); is( $rec->event_stops->minute, $min_of_day->minute, "Correct value"); is( $rec->event_stops->hour, $min_of_day->hour, "Correct value"); # undef/NULL $rec->set_created; is($rec->created, undef, "Set undef value" ); # Create using default undef my $rec2 = TestApp::User->new( handle => $handle ); isa_ok($rec2, 'Jifty::DBI::Record'); is($rec2->created, undef, 'Default of undef'); # from string require POSIX; $rec->set_created( POSIX::strftime( "%Y-%m-%d %H:%M:%S", gmtime($now) ) ); isa_ok($rec->created, 'DateTime' ); is( $rec->created->epoch, $now, "Correct value"); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); } } package TestApp::User; use base qw/Jifty::DBI::Record/; 1; sub schema_sqlite { < type is 'datetime', filters are qw/Jifty::DBI::Filter::DateTime/, default is undef; column event_on => type is 'date', filters are qw/Jifty::DBI::Filter::Date/; column event_stops => type is 'time', filters are qw/Jifty::DBI::Filter::Time/; } } 1; Jifty-DBI-0.77/t/03rebless.t0000644000175000017500000000160011305565770014400 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; use Jifty::DBI::Handle; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 4; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { SKIP: { unless( should_test( $d ) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } my $handle = Jifty::DBI::Handle->new; ok($handle, "Made a generic handle"); is(ref $handle, 'Jifty::DBI::Handle', "It's really generic"); connect_handle_with_driver( $handle, $d ); isa_ok($handle->dbh, 'DBI::db'); isa_ok($handle, "Jifty::DBI::Handle::$d", "Specialized Handle"); disconnect_handle_with_driver( $handle, $d ); }} # SKIP, foreach blocks 1; Jifty-DBI-0.77/t/01records.t0000644000175000017500000002627711576426730014423 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 72; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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 => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); # _accessible testings is( $rec->_accessible('id' => 'read'), 1, 'id is accessible for read' ); is( $rec->_accessible('id' => 'write'), 0, 'id is not accessible for write' ); is( $rec->_accessible('id'), undef, "any column is not accessible in undefined mode" ); is( $rec->_accessible('unexpected_column' => 'read'), undef, "column doesn't exist and can't be accessible for read" ); is_deeply( [sort($rec->readable_attributes)], [sort qw(address employee_id id name phone)], 'readable attributes' ); is_deeply( [sort($rec->writable_attributes)], [sort qw(address employee_id name phone)], 'writable attributes' ); is $rec->column('employee_id')->sort_order, -1, "got manual sort order"; can_ok($rec,'create'); # Test create and load as class methods my $record2 = TestApp::Address->create( _handle => $handle, name => 'Enoch', phone => '123 456 7890'); isa_ok($record2, 'TestApp::Address'); ok($record2->id, "Created a record with a class method"); is_deeply({ $record2->as_hash }, { id => $record2->id, employee_id => undef, name => 'Enoch', address => '', phone => '123 456 7890', }, 'as_hash works'); my $clone2 = TestApp::Address->load_by_cols( _handle => $handle, name => 'Enoch'); isa_ok($clone2, 'TestApp::Address'); is($clone2->phone, '123 456 7890'); { local *TestApp::Address::_handle = sub { return $handle}; my $clone_by_id = TestApp::Address->load($record2->id); isa_ok($clone_by_id, 'TestApp::Address'); is($clone_by_id->phone, '123 456 7890'); } 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->set_name('Obra'); ok($val, $msg) ; is($rec->name, 'Obra', "We did actually change the name"); # Validate immutability of the column id ($val, $msg) = $rec->set_id( $rec->id + 1 ); ok(!$val, $msg); is($msg, 'Immutable column', 'id is immutable column'); is($rec->id, $id, "The record still has its id"); # Check some non existent column ok( !eval{ $rec->some_unexpected_column }, "The record has no 'some_unexpected_column'"); { # test produce DBI warning local $SIG{__WARN__} = sub {return}; is( $rec->_value( 'some_unexpected_column' ), undef, "The record has no 'some_unexpected_column'"); } ok (!eval { $rec->set_some_unexpected_column( 'foo' )}, "Can't call nonexistent columns"); ($val, $msg) = $rec->_set(column =>'some_unexpected_column', value =>'foo'); ok(!$val, defined $msg ? $msg : ""); # Validate truncation on update ($val,$msg) = $rec->set_name('1234567890123456789012345678901234567890'); ok($val, $msg); is($rec->name, '12345678901234', "Truncated on update"); # make sure we do _not_ truncate things which should not be truncated ($val,$msg) = $rec->set_employee_id('1234567890'); ok($val, $msg) ; is($rec->employee_id, '1234567890', "Did not truncate id on create"); #delete prev record $rec->delete; # make sure we do truncation on create my $newrec = TestApp::Address->new( handle => $handle ); my $newid = $newrec->create( name => '1234567890123456789012345678901234567890', employee_id => '1234567890' ); $newrec->load($newid); ok ($newid, "Created a new record"); is($newrec->name, '12345678901234', "Truncated on create"); is($newrec->employee_id, '1234567890', "Did not truncate id on create"); # no prefetch feature and _load_from_sql sub checks $newrec = TestApp::Address->new( handle => $handle ); ($val, $msg) = $newrec->_load_from_sql('SELECT id FROM addresses WHERE id = ?', $newid); is($val, 1, 'found object'); is($newrec->name, '12345678901234', "autoloaded not prefetched column"); is($newrec->employee_id, '1234567890', "autoloaded not prefetched column"); # _load_from_sql and missing PK $newrec = TestApp::Address->new( handle => $handle ); ($val, $msg) = $newrec->_load_from_sql('SELECT name FROM addresses WHERE name = ?', '12345678901234'); is($val, 0, "didn't find object"); is($msg, "Missing a primary key?", "reason is missing PK"); # _load_from_sql and not existent row $newrec = TestApp::Address->new( handle => $handle ); ($val, $msg) = $newrec->_load_from_sql('SELECT id FROM addresses WHERE id = ?', 0); is($val, 0, "didn't find object"); is($msg, "Couldn't find row", "reason is wrong id"); # _load_from_sql and wrong SQL $newrec = TestApp::Address->new( handle => $handle ); { local $SIG{__WARN__} = sub{return}; ($val, $msg) = $newrec->_load_from_sql('SELECT ...'); } is($val, 0, "didn't find object"); is($msg, "Couldn't execute query", "reason is bad SQL"); # test load_* methods $newrec = TestApp::Address->new( handle => $handle ); $newrec->load(); is( $newrec->id, undef, "can't load record with undef id"); $newrec = TestApp::Address->new( handle => $handle ); $newrec->load_by_cols( name => '12345678901234' ); is( $newrec->id, $newid, "load record by 'name' column value"); # load_by_col with operator $newrec = TestApp::Address->new( handle => $handle ); $newrec->load_by_cols( name => { value => '%45678%', operator => 'LIKE' } ); is( $newrec->id, $newid, "load record by 'name' with LIKE"); # load_by_primary_keys $newrec = TestApp::Address->new( handle => $handle ); ($val, $msg) = $newrec->load_by_primary_keys( id => $newid ); ok( $val, "load record by PK"); is( $newrec->id, $newid, "loaded correct record"); $newrec = TestApp::Address->new( handle => $handle ); ($val, $msg) = $newrec->load_by_primary_keys( {id => $newid} ); ok( $val, "load record by PK"); is( $newrec->id, $newid, "loaded correct record" ); $newrec = TestApp::Address->new( handle => $handle ); ($val, $msg) = $newrec->load_by_primary_keys( phone => 'some' ); ok( !$val, "couldn't load, missing PK column"); is( $msg, "Missing PK column: 'id'", "right error message" ); # Defaults kick in $rec = TestApp::Address->new( handle => $handle ); $id = $rec->create( name => 'Chmrr' ); ok( $id, "new record"); $rec = TestApp::Address->new( handle => $handle ); $rec->load_by_cols( name => 'Chmrr' ); is( $rec->id, $id, "loaded record by empty value" ); is( $rec->address, '', "Got default on create" ); # load_by_cols and empty or NULL values $rec = TestApp::Address->new( handle => $handle ); $id = $rec->create( name => 'Obra', phone => undef ); ok( $id, "new record"); $rec = TestApp::Address->new( handle => $handle ); $rec->load_by_cols( name => 'Obra', phone => undef, employee_id => '' ); is( $rec->id, $id, "loaded record by empty value" ); # __set error paths $rec = TestApp::Address->new( handle => $handle ); $rec->load( $id ); $val = $rec->set_name( '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->set_name( 'invalid' ); isa_ok( $val, 'Class::ReturnValue', "couldn't set invalid value, error returned"); is( ($val->as_array)[1], 'Illegal value for name', "correct error message" ); is( $rec->name, 'Obra', "old value is still there"); # XXX TODO FIXME: this test cover current implementation that is broken //RUZ # fixed, now we can set undef values(NULLs) $val = $rec->set_name( ); isa_ok( $val, 'Class::ReturnValue', "set empty/undef/NULL value"); is( ($val->as_array)[1], "The new value has been set.", "correct error message" ); is( $rec->name, undef, "new value is undef, NULL in DB"); # deletes $newrec = TestApp::Address->new( handle => $handle ); $newrec->load( $newid ); is( $newrec->delete, 1, 'successfuly delete record'); $newrec = TestApp::Address->new( handle => $handle ); $newrec->load( $newid ); is( $newrec->id, undef, "record doesn't exist any more"); cleanup_schema( 'TestApp::Address', $handle ); disconnect_handle( $handle ); }} # SKIP, foreach blocks 1; package TestApp::Address; use base qw/Jifty::DBI::Record/; sub validate_name { my ($self, $value) = @_; return 0 if $value && $value =~ /invalid/i; return 1; } sub schema_mysql { < till 999, type is 'varchar(14)'; column phone => type is 'varchar(18)'; column address => type is 'varchar(50)', default is ''; column employee_id => type is 'int(8)', order is -1; } } 1; Jifty-DBI-0.77/t/06filter_utf8.t0000644000175000017500000000764511305565770015216 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 24; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; use DateTime (); foreach my $d ( @available_drivers ) { SKIP: { unless( has_schema( 'TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); {my $ret = init_schema( 'TestApp::User', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} $handle->input_filters( 'Jifty::DBI::Filter::utf8' ); is( ($handle->input_filters)[0], 'Jifty::DBI::Filter::utf8', 'Filter was added' ); my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); # "test" in Russian my $str = "\x{442}\x{435}\x{441}\x{442}"; my($id) = $rec->create( signature => $str ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); ok( Encode::is_utf8($rec->signature), "Value is UTF-8" ); is( $rec->signature, $str, "Value is the same" ); # correct data with no UTF-8 flag my $nstr = Encode::encode_utf8( $str ); ($id) = $rec->create( signature => $nstr ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); ok( Encode::is_utf8($rec->signature), "Value is UTF-8" ); is( $rec->signature, $str, "Value is the same" ); # cut string in the middle of the unicode char # and drop flag, leave only first char and # a half of the second so in result we will # get only one char $nstr = do{ use bytes; substr( $str, 0, 3 ) }; ($id) = $rec->create( signature => $nstr ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); ok( Encode::is_utf8($rec->signature), "Value is UTF-8" ); is( $rec->signature, "\x{442}", "Value is correct" ); # UTF-8 string with flag unset and enabeld trancation # truncation should cut third char, but utf8 filter should # replace it with \x{fffd} code point $rec->set_name( Encode::encode_utf8($str) ); is($rec->name, "\x{442}\x{435}", "Name was truncated to two UTF-8 chars" ); # create with undef value, no utf8 or truncate magic ($id) = $rec->create( signature => undef ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); is($rec->signature, undef, "successfuly stored and fetched undef"); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); } } package TestApp::User; use base qw/Jifty::DBI::Record/; sub schema_sqlite { < type is 'varchar(5)'; column signature => type is 'varchar(100)'; } } 1; Jifty-DBI-0.77/t/15types.t0000644000175000017500000000656011305565770014122 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 16; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; use DateTime (); foreach my $d ( @available_drivers ) { SKIP: { unless( has_schema( 'TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); {my $ret = init_schema( 'TestApp::User', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my $now = time; my $today = DateTime->from_epoch( epoch => $now )->truncate( to => 'day' )->epoch; my $min_of_day = DateTime->from_epoch( epoch => $now )->truncate( to => 'minute' ); my $dt = DateTime->from_epoch( epoch => $now ); my ($id) = $rec->create( created => $dt, event_on => $dt, event_stops => $min_of_day ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); isa_ok($rec->created, 'DateTime' ); is( $rec->created->epoch, $now, "Correct value"); isa_ok($rec->event_on, 'DateTime' ); is( $rec->event_on->epoch, $today, "Correct value"); isa_ok($rec->event_stops, 'DateTime' ); is( $rec->event_stops->minute, $min_of_day->minute, "Correct value"); is( $rec->event_stops->hour, $min_of_day->hour, "Correct value"); # undef/NULL $rec->set_created; is($rec->created, undef, "Set undef value" ); # from string require POSIX; $rec->set_created( POSIX::strftime( "%Y-%m-%d %H:%M:%S", gmtime($now) ) ); isa_ok($rec->created, 'DateTime' ); is( $rec->created->epoch, $now, "Correct value"); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); } } package TestApp::User; use base qw/Jifty::DBI::Record/; 1; sub schema_sqlite { <register_types( Date => sub { type is 'date', input_filters are qw/Jifty::DBI::Filter::Date/ }, Time => sub { type is 'time', input_filters are qw/Jifty::DBI::Filter::Time/ }, DateTime => sub { type is 'datetime', input_filters are qw/Jifty::DBI::Filter::DateTime/ } ); } use Jifty::DBI::Record schema { column created => is DateTime; column event_on => is Date; column event_stops => is Time; }; 1; Jifty-DBI-0.77/t/14handle-pg.t0000644000175000017500000000323312115431272014573 0ustar chmrrchmrr# Test methods in Jifty::DBI::Handle::Pg use strict; use warnings; use Test::More tests => 2; my $package; BEGIN { $package = 'Jifty::DBI::Handle::Pg'; use_ok($package); } use Jifty::DBI::Collection; package Foo::Bar::Collection; our @ISA = 'Jifty::DBI::Collection'; sub query_columns { "blah" } sub table { "bars" } package main; { # Test sub distinct_query my $collection = bless { order_by => [ { alias => 'main', column => 'id', order => 'asc', }, { alias => 'main', column => 'name', order => 'desc', }, { alias => 'foo', column => 'id', order => 'desc', }, { alias => 'foo', column => 'name', order => 'desc', }, { alias => '', column => 'id', order => 'ASC', }, { alias => undef, column => 'blood', order => 'ASC' }, { column => 'session_offset', order => 'asc' }, ], }, 'Foo::Bar::Collection'; my $stmt = 'select * from users'; $package->distinct_query(\$stmt, $collection); is $stmt, 'SELECT blah FROM ( SELECT main.id FROM select * from users GROUP BY main.id' . ' ORDER BY main.id ASC, MAX(main.name) DESC, MAX(foo.id) DESC, ' . 'MAX(foo.name) DESC, id ASC, MIN(blood) ASC, MIN(session_offset) ASC ) ' . 'distinctquery, bars main WHERE (main.id = distinctquery.id)', 'distinct_query works'; } Jifty-DBI-0.77/t/01searches.t0000644000175000017500000004434611547356424014554 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 109; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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::UserCollection->new( handle => $handle ); isa_ok( $users_obj, 'Jifty::DBI::Collection' ); 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->_record_count, 0, '_record_count returns 0 on not limited obj' ); is( $users_obj->count, 0, 'count returns 0 on not limited obj' ); is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after count' ); is( $users_obj->first, undef, 'first returns undef on not limited obj' ); is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after first' ); is( $users_obj->last, undef, 'last returns undef on not limited obj' ); is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after last' ); $users_obj->goto_first_item; is( $users_obj->peek, undef, 'peek returns undef on not limited obj' ); is( $users_obj->next, undef, 'next returns undef on not limited obj' ); is( $users_obj->is_last, undef, 'is_last returns undef on not limited obj after next' ); # XXX TODO FIXME: may be this methods should be implemented # $users_obj->goto_last_item; # is( $users_obj->prev, undef, 'prev returns undef on not limited obj' ); my $items_ref = $users_obj->items_array_ref; isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' ); is_deeply( $items_ref, [], 'items_array_ref 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, 'Jifty::DBI::Record', 'first returns record object' ); isa_ok( $users_obj->last, 'Jifty::DBI::Record', 'last returns record object' ); $users_obj->goto_first_item; isa_ok( $users_obj->peek, 'Jifty::DBI::Record', 'peek returns record object' ); isa_ok( $users_obj->next, 'Jifty::DBI::Record', 'next returns record object' ); $items_ref = $users_obj->items_array_ref; isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' ); is( scalar @{$items_ref}, $count_all, 'items_array_ref returns same number of records as was inserted' ); $users_obj->redo_search; $items_ref = $users_obj->items_array_ref; isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' ); is( scalar @{$items_ref}, $count_all, 'items_array_ref returns same number of records as was inserted' ); # try to use $users_obj for all tests, after each call to clean_slate it should look like new obj. # and test $obj->new syntax my $clean_obj = $users_obj->new( handle => $handle ); isa_ok( $clean_obj, 'Jifty::DBI::Collection' ); # basic limits $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'login', value => 'obra' ); is( $users_obj->count, 1, 'found one user with login obra' ); TODO: { local $TODO = 'require discussion'; is( $users_obj->is_last, undef, 'is_last returns undef before we fetch any record' ); } my $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $users_obj->is_last, 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->is_last, 1, 'is_last always returns 1 after last call'); $users_obj->goto_first_item; my $peek_rec = $users_obj->peek; my $next_rec = $users_obj->next; is( $next_rec, $peek_rec, 'peek returns same object as next' ); is( $next_rec, $first_rec, 'next returns same object as first' ); is( $users_obj->is_last, 1, 'is_last returns 1 after fetch first record with next method'); is( $users_obj->peek, undef, 'only one record in the collection' ); is( $users_obj->next, undef, 'only one record in the collection' ); TODO: { local $TODO = 'require discussion'; is( $users_obj->is_last, undef, 'next returns undef, is_last returns undef too'); } $items_ref = $users_obj->items_array_ref; isa_ok( $items_ref, 'ARRAY', 'items_array_ref always returns array reference' ); is( scalar @{$items_ref}, 1, 'items_array_ref has only 1 record' ); # similar basic limit, but with different operators and less first/next/last tests # LIKE $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'Glass' ); is( $users_obj->count, 1, "found one user with 'Glass' in the name" ); $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'glasser', 'login is correct' ); # LIKE with wildcard $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'G_ass' ); is( $users_obj->count, 1, "found one user with 'Glass' in the name" ); $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'glasser', 'login is correct' ); # LIKE with escaped wildcard $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); # XXX: don't use backslashes; Pg (only Pg?) requires special # treatment like "LIKE E'%g\\_ass%'" for that case, # which is not supported yet (but this should be fixed) $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'G@_ass', escape => '@' ); is( $users_obj->count, 0, "should not find users with 'Glass' in the name" ); # LIKE with wildcard $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'Glass%' ); is( $users_obj->count, 1, "found one user with 'Glass' in the name" ); $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'glasser', 'login is correct' ); # MATCHES with escaped wildcard $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); # XXX: don't use backslashes; reason above $users_obj->limit( column => 'name', operator => 'MATCHES', value => 'Glass@%', escape => '@' ); is( $users_obj->count, 0, "should not find users with 'Glass' in the name" ); # STARTSWITH $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => '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, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'cubic', 'login is correct' ); # ENDSWITH $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => '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, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'audreyt', 'login is correct' ); # IN $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'login', operator => 'IN', value => ['cubic', 'obra', 'glasser', 'audreyt'] ); is( $users_obj->count, 4, "found 4 user ids" ); my %logins = (cubic => 1, obra => 1, glasser => 1, audreyt => 1); while ( my $user = $users_obj->next ) { is ( defined $logins{$user->login}, 1, 'Found login' ); delete $logins{$user->login}; } is ( scalar( keys( %logins ) ), 0, 'All logins found' ); # IS NULL # XXX TODO FIXME: column => undef should be handled as NULL $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'phone', operator => 'IS', value => 'NULL' ); is( $users_obj->count, 2, "found 2 users who has unknown phone number" ); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'address', operator => 'IS', value => 'NULL' ); is( $users_obj->count, 0, "found 0 users who has unknown address" ); # IS NOT NULL $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'phone', operator => 'IS NOT', value => 'NULL', quotevalue => 0 ); is( $users_obj->count, $count_all - 2, "found users who have phone number filled" ); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'address', operator => 'IS NOT', value => 'NULL', quotevalue => 0 ); is( $users_obj->count, $count_all, "found users who have address filled" ); # CASE SENSITIVITY, default is limits are not case sensitive $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => 'Jesse Vincent' ); is( $users_obj->count, 1, "case insensitive, matching case, should find one row"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => 'jesse vincent' ); is( $users_obj->count, 1, "case insensitive, non-matched case, should find one row"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => ['Jesse Vincent', 'Audrey Tang'], operator => 'IN'); is( $users_obj->count, 2, "case insensitive, matching case, should find two rows"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => ['jesse vincent', 'audrey tang'], operator => 'IN'); is( $users_obj->count, 2, "case insensitive, non-matched case, should find two rows"); # CASE SENSITIVITY, testing with case_sensitive => 1 $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => 'Jesse Vincent', case_sensitive => 1 ); is( $users_obj->count, 1, "case sensitive search, should find one row"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => 'jesse vincent', case_sensitive => 1 ); TODO: { local $TODO = "MySQL still needs case sensitive fixes" if ( $d eq 'mysql' || $d eq 'mysqlPP' ); is( $users_obj->count, 0, "case sensitive search, should find zero rows"); } $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => ['Jesse Vincent', 'Audrey Tang'], operator => 'IN', case_sensitive => 1 ); is( $users_obj->count, 2, "case sensitive search, should find two rows"); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'name', value => ['jesse vincent', 'audrey tang'], operator => 'IN', case_sensitive => 1 ); TODO: { local $TODO = "MySQL still needs case sensitive fixes" if ( $d eq 'mysql' || $d eq 'mysqlPP' ); is( $users_obj->count, 0, "case sensitive search, should find zero rows"); } # ORDER BY / GROUP BY $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->unlimit; $users_obj->group_by(column => 'login'); $users_obj->order_by(column => 'login', order => 'desc'); $users_obj->column(column => 'login'); is( $users_obj->count, $count_all, "group by / order by finds right amount"); $first_rec = $users_obj->first; isa_ok( $first_rec, 'Jifty::DBI::Record', 'First returns record object' ); is( $first_rec->login, 'obra', 'login is correct' ); $users_obj->clean_slate; TODO: { local $TODO = 'we leave order_by after clean slate, fixing this results in many RT failures'; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj = TestApp::UserCollection->new( handle => $handle ); } # Let's play a little with 'entry_aggregator' # EA defaults to OR for the same field $users_obj->limit( column => 'phone', operator => 'IS', value => 'NULL', quote_value => 0 ); $users_obj->limit( column => '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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'Login', operator => 'NOT LIKE', value => '%c%' ); $users_obj->limit( entry_aggregator => 'AND', column => '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->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); $users_obj->limit( column => 'phone', operator => 'IS', value => 'NULL', quote_value => 0 ); $users_obj->limit( column => 'login', operator => 'LIKE', value => '%r%' ); is( $users_obj->count, 2, "found users who has no phone number or login has 'r' char" ); $users_obj->clean_slate; is_deeply( $users_obj, $clean_obj, 'after clean_slate looks like new object'); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql { <table('users'); $self->SUPER::_init(@_); } sub init_data { return ( [ 'login', 'name', 'phone', 'address' ], [ 'cubic', 'Ruslan U. Zakirov', '+7-903-264-XX-XX', undef ], [ 'obra', 'Jesse Vincent', undef, undef ], [ 'glasser', 'David Glasser', undef, 'somewhere' ], [ 'audreyt', 'Audrey Tang', '+X-XXX-XXX-XX-XX', 'someplace' ], ); } 1; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column login => type is 'varchar(18)'; column name => type is 'varchar(36)'; column phone => type is 'varchar(18)', default is undef; column address => type is 'varchar(18)', default is ''; } } 1; package TestApp::UserCollection; # use TestApp::User; use base qw/Jifty::DBI::Collection/; sub _init { my $self = shift; $self->SUPER::_init(@_); $self->table('users'); } 1; Jifty-DBI-0.77/t/02-column_constraints.t0000644000175000017500000000546311305565770016754 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More;# import => [qw(isa_ok skip plan)]; use Test::Warn; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 9; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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 => $handle ); my $e_id = $emp->create( name => 'RUZ', employee_num => '123' ); ok($e_id, "Got an id for the new employee"); # Test 'is mandatory' warning_like { $e_id = $emp->create( employee_num => '456' ); } qr/^Did not supply value for mandatory column name/; ok(!$e_id, "Did not get an id for second new employee, good"); # Test 'is distinct' $e_id = $emp->create( name => 'Foo', employee_num => '456' ); ok($e_id, "Was able to create a second record successfully"); my $e_id2; warning_like { $e_id2 = $emp->create( name => 'Bar', employee_num => '123' ); } qr/^TestApp::Employee=HASH\(\w+\) failed a 'is_distinct' check for employee_num on 123/; ok(!$e_id2, "is_distinct prevents us from creating another record"); my $obj = TestApp::Employee->new( handle => $handle ); $obj->load( $e_id ); ok(!$obj->set_employee_num('123'), "is_distinct prevents us from modifying a record to a duplicate value"); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE table employees ( id integer primary key, name varchar(36) NOT NULL, employee_num int(8) ) } ] } sub schema_mysql { [ q{ CREATE TEMPORARY table employees ( id integer AUTO_INCREMENT primary key, name varchar(36) NOT NULL, employee_num int(8) ) } ] } sub schema_pg { [ q{ CREATE TEMPORARY table employees ( id serial PRIMARY KEY, name varchar NOT NULL, employee_num integer ) } ] } package TestApp::Employee; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column name => type is 'varchar(18)', is mandatory; column employee_num => type is 'int(8)', is distinct; } } 1; Jifty-DBI-0.77/t/10schema.t0000644000175000017500000001604412115431272014174 0ustar chmrrchmrr#!/usr/bin/env perl use strict; use warnings; use Test::More; use version; use constant TESTS_PER_DRIVER => 87; our @available_drivers; BEGIN { require("t/utils.pl"); my $total = 3 + scalar(@available_drivers) * TESTS_PER_DRIVER; if( not eval { require DBIx::DBSchema } ) { plan skip_all => "DBIx::DBSchema not installed"; } else { plan tests => $total; } } BEGIN { use_ok("Jifty::DBI::SchemaGenerator"); use_ok("Jifty::DBI::Handle"); } require_ok("t/testmodels.pl"); foreach my $d ( @available_drivers ) { SKIP: { my $address_schema = has_schema('Sample::Address',$d); my $employee_schema = has_schema('Sample::Employee',$d); my $corporation_schema = has_schema('Sample::Corporation',$d); unless ($address_schema && $employee_schema && $corporation_schema) { skip "need to work on $d", TESTS_PER_DRIVER; } unless( should_test( $d ) ) { skip "ENV is not defined for driver $d", TESTS_PER_DRIVER; } # Test that declarative schema syntax automagically sets validators # correctly. ok( Sample::Address->can('validate_name'), 'found validate_name' ); my $validator = Sample::Address->column('name')->validator; ok( $validator, 'found $column->validator' ); is( $validator, \&Sample::Address::validate_name, 'validators match' ); my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle, "Jifty::DBI::Handle::$d"); isa_ok($handle->dbh, 'DBI::db'); my $SG = Jifty::DBI::SchemaGenerator->new($handle); isa_ok($SG, 'Jifty::DBI::SchemaGenerator'); isa_ok($SG->_db_schema, 'DBIx::DBSchema'); is($SG->create_table_sql_text, '', "no tables means no sql"); my $ret = $SG->add_model('Sample::This::Does::Not::Exist'); ok(not ($ret), "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->create_table_sql_text, '', "no tables means no sql"); $ret = $SG->add_model('Sample::Address'); ok($ret != 0, "added model from real class"); is_ignoring_space($SG->create_table_sql_text, Sample::Address->$address_schema, "got the right Address schema for $d"); my $employee = Sample::Employee->new; isa_ok($employee, 'Sample::Employee'); can_ok($employee, qw( label type dexterity age )); $ret = $SG->add_model($employee); ok($ret != 0, "added model from an instantiated object"); is_ignoring_space($SG->create_table_sql_text, Sample::Address->$address_schema. Sample::Employee->$employee_schema, "got the right Address+Employee schema for $d"); my $corporation = Sample::Corporation->new; isa_ok($corporation, 'Sample::Corporation'); can_ok($corporation, qw( name )); $ret = $SG->add_model($corporation); ok($ret != 0, "added model from an instantiated object"); is_ignoring_space($SG->create_table_sql_text, Sample::Address->$address_schema. Sample::Corporation->$corporation_schema . Sample::Employee->$employee_schema, "got the right Address+Corporation+Employee schema for $d"); my $manually_make_text = join ' ', map { "$_;" } $SG->create_table_sql_statements; is_ignoring_space($SG->create_table_sql_text, $manually_make_text, 'create_table_sql_text is the statements in create_table_sql_statements'); my $version_024_min = version->new('0.2.4'); my $version_024_max = version->new('0.2.8'); for my $version (qw/ 0.2.0 0.2.4 0.2.6 0.2.8 0.2.9 /) { Sample::Address->_COLUMNS_CACHE(undef); Sample::Address->schema_version($version); my $SG = Jifty::DBI::SchemaGenerator->new($handle, $version); $SG->add_model('Sample::Address'); my $street_added = version->new($version) >= $version_024_min && version->new($version) < $version_024_max; ok(Sample::Address->COLUMNS->{id}->active, 'id active'); ok(Sample::Address->COLUMNS->{employee_id}->active, 'employee_id active'); ok(Sample::Address->COLUMNS->{name}->active, 'name active'); ok(Sample::Address->COLUMNS->{phone}->active, 'phone active'); if ($street_added) { ok(Sample::Address->COLUMNS->{street}->active, 'street active'); } else { ok(!Sample::Address->COLUMNS->{street}->active, 'street not active'); } # employee_id shows up twice when we map over name because employee # is automagically injected as an aliased column is_deeply([map { $_->name } Sample::Address->all_columns], [qw(id employee_id employee_id name phone street)], "got all columns"); is_deeply([map { $_->name } Sample::Address->columns], [qw(id employee_id employee_id name phone), ($street_added ? qw(street) : ())], "got all active columns"); my $address_version_schema = $street_added ? "${address_schema}_024" : $address_schema; is_ignoring_space($SG->create_table_sql_text, Sample::Address->$address_version_schema, "got the right Address schema for $d version $version"); } for my $version (qw/ 0.2.0 0.2.4 0.2.6 0.2.8 0.2.9 /) { Sample::Corporation->schema_version($version); my $SG = Jifty::DBI::SchemaGenerator->new($handle, $version); $SG->add_model('Sample::Corporation'); my $needs_state = version->new($version) >= $version_024_min && version->new($version) < $version_024_max; ok(Sample::Corporation->COLUMNS->{id}->active, 'id active'); ok(Sample::Corporation->COLUMNS->{name}->active, 'name active'); if ($needs_state) { ok(Sample::Corporation->COLUMNS->{us_state}->active, "state active for version $version"); ok(Sample::Corporation->COLUMNS->{us_state}->mandatory, "state mandatory for version $version"); } else { ok(!Sample::Corporation->COLUMNS->{us_state}->active, "state not active for version $version"); ok(Sample::Corporation->COLUMNS->{us_state}->mandatory, "state still mandatory for version $version"); } my $corporation_version_schema = $needs_state ? "${corporation_schema}_024" : $corporation_schema; is_ignoring_space($SG->create_table_sql_text, Sample::Corporation->$corporation_version_schema, "got the right Corporation schema for $d version $version"); } cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); } } sub is_ignoring_space { my $a = shift; my $b = shift; for my $item ( $b, $a ) { $item =~ s/^\s+//; $item =~ s/\s+$//; $item =~ s/\s+/ /g; $item =~ s/\s+;/;/g; $item =~ s/\(\s+(.*?)\s+\)/($1)/g; unshift @_, $item; } goto &is; } Jifty-DBI-0.77/t/04memcached.t0000644000175000017500000000675411305565770014667 0ustar chmrrchmrr#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { require 't/utils.pl' } use constant TESTS_PER_DRIVER => 1; our (@available_drivers); my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; # plan tests => $total; BEGIN { eval { require Cache::Memcached; Cache::Memcached->import; }; plan skip_all => 'Cache::Memcached not available' if $@; } my $memd = Cache::Memcached->new({TestApp::Address->memcached_config}); plan skip_all => 'Memcached apparently not running' unless $memd->set('test_testval', 0, 1); plan 'no_plan'; for my $d (@available_drivers) { 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" );} # Create a record, load from cache my $rec = TestApp::Address->new( handle => $handle ); 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 => $handle ); my ( $status, $msg ) = $rec_cache->load_by_cols( id => $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' ); is( $rec_cache->phone, '617 124 567', "Loaded the phone number correctly"); # Check mutation $rec->set_phone('555 543 6789'); is($rec->phone, '555 543 6789'); $rec = TestApp::Address->new( handle => $handle ); $rec->load($id); is($rec->phone, '555 543 6789', "Loaded changed data from cache OK"); disconnect_handle($handle); }} package TestApp::Address; use base qw/Jifty::DBI::Record::Memcached/; # Make this unique per run and database, since otherwise we'll get # stale caches when we run for the 2nd and future drivers sub cache_key_prefix { my $self = shift; my $driver = ref($self->_handle); $driver = lc $1 if $driver =~ /::(\w+)$/; return "jifty-test-$$-$driver"; } sub schema_mysql { < type is 'varchar(14)'; column phone => type is 'varchar(18)'; column address => type is 'varchar(50)', default is ''; column employee_id => type is 'int(8)'; } } 1; Jifty-DBI-0.77/t/16inheritance.t0000644000175000017500000001047311305565770015246 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 17; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; use DateTime (); foreach my $d ( @available_drivers ) { SKIP: { unless( has_schema( 'TestApp::CrazyUser', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); {my $ret = init_schema( 'TestApp::User', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} {my $ret = init_schema( 'TestApp::CrazyUser', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back" );} my $rec = TestApp::CrazyUser->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my $now = time; my $today = DateTime->from_epoch( epoch => $now )->truncate( to => 'day' )->epoch; my $min_of_day = DateTime->from_epoch( epoch => $now )->truncate( to => 'minute' ); my $dt = DateTime->from_epoch( epoch => $now ); my ($id) = $rec->create( created => $dt, event_on => $dt, event_stops => $min_of_day ); ok($id, "Successfuly created ticket"); ok($rec->load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); isa_ok($rec->created, 'DateTime' ); is( $rec->created->epoch, $now, "Correct value"); isa_ok($rec->event_on, 'DateTime' ); is( $rec->event_on->epoch, $today, "Correct value"); isa_ok($rec->event_stops, 'DateTime' ); is( $rec->event_stops->minute, $min_of_day->minute, "Correct value"); is( $rec->event_stops->hour, $min_of_day->hour, "Correct value"); # undef/NULL $rec->set_created; is($rec->created, undef, "Set undef value" ); # from string require POSIX; $rec->set_created( POSIX::strftime( "%Y-%m-%d %H:%M:%S", gmtime($now) ) ); isa_ok($rec->created, 'DateTime' ); is( $rec->created->epoch, $now, "Correct value"); cleanup_schema( 'TestApp', $handle ); disconnect_handle( $handle ); } } package TestApp::User; use base qw/Jifty::DBI::Record/; 1; sub schema_sqlite { <register_types( Date => sub { type is 'date', input_filters are qw/Jifty::DBI::Filter::Date/ }, Time => sub { type is 'time', input_filters are qw/Jifty::DBI::Filter::Time/ }, DateTime => sub { type is 'datetime', input_filters are qw/Jifty::DBI::Filter::DateTime/ } ); } use Jifty::DBI::Record schema { column created => is DateTime; column event_on => is Date; column event_stops => is Time; }; package TestApp::CrazyUser; BEGIN { our @ISA =qw(TestApp::User); } use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column craziness => type is 'text'; # column event_on => is mandatory; }; sub schema_sqlite { < 139; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; my @true = qw/1 t true y yes TRUE/; my @false = qw/0 f false n no FALSE/; foreach my $d (@available_drivers) { SKIP: { unless (has_schema('TestApp::User', $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("start testing with '$d' handle") if $ENV{TEST_VERBOSE}; my $handle = get_handle($d); connect_handle($handle); isa_ok($handle->dbh, 'DBI::db'); { my $ret = init_schema('TestApp::User', $handle); isa_ok($ret, 'DBI::st', 'init schema'); } my @values = ( ( map { [$_, 'true'] } @true ), ( map { [$_, 'false'] } @false ), ); for my $value ( @values, [undef, 'false'] ) { my ($input, $bool) = @$value; my $rec = TestApp::User->new( handle => $handle ); isa_ok($rec, 'Jifty::DBI::Record'); my ($id) = $rec->create( defined($input) ? (my_data => $input) : () ); ok($id, 'created record'); ok($rec->load($id), 'loaded record'); is($rec->id, $id, 'record id matches'); is($rec->my_data, $bool eq 'true' ? 1 : 0, 'Perl agrees with the expected boolean value'); if ($d eq 'Pg') { # this option tells DBD::Pg to keep booleans as 't' and 'f' and not # map them to 1 and 0 $handle->dbh->{pg_bool_tf} = 1; } my $sth = $handle->simple_query("SELECT my_data FROM users WHERE id = $id"); my ($got) = $sth->fetchrow_array; my $method = "canonical_$bool"; is( $got, $handle->$method, "my_data bool match for " . (defined($input) ? $input : 'undef') . " ($bool)" ); if ($d eq 'Pg') { $handle->dbh->{pg_bool_tf} = 0; } # undef/NULL $rec->set_my_data; is($rec->my_data, undef, 'set undef value'); $rec->set_my_data($input); ok($bool eq 'true' ? $rec->my_data : !$rec->my_data, 'Perl agrees with the expected boolean value'); } for my $value ( @values ) { my ($input, $bool) = @$value; my $rec = TestApp::User->new( handle => $handle ); $rec->load_by_cols( my_data => $input, ); ok($rec->id, "loaded a record by boolean value '$input'"); my $col = TestApp::UserCollection->new( handle => $handle ); $col->limit( column => 'my_data', value => $input, ); if ($col->count) { ok($bool eq 'true' ? $col->first->my_data : !$col->first->my_data, 'Perl agrees with the expected boolean value'); } else { fail("Got no results from limit"); } } # Test undef for boolean columns marked mandatory my $rec = TestApp::User->new( handle => $handle ); my ($id) = $rec->create(); ok($id, 'created record'); ok($rec->load($id), 'loaded record'); is($rec->id, $id, 'record id matches'); is($rec->other_data, 0, 'default mandatory column is false, not undef'); is($rec->def_t, 1, 'default is correct if given as "t"'); is($rec->def_one, 1, 'default is correct if given as 1'); is($rec->def_zero, 0, 'default is correct if given as 0'); $rec->set_other_data(1); is($rec->other_data, 1, 'mandatory column is now true'); $rec->set_other_data(undef); is($rec->other_data, 0, 'mandatory column set to undef is now false, not undef'); cleanup_schema('TestApp', $handle); disconnect_handle($handle); } } package TestApp::User; use base qw/ Jifty::DBI::Record /; sub schema_sqlite { < is boolean; column other_data => is boolean, is mandatory; column def_t => is boolean, default is 't'; column def_one => is boolean, default is 1; column def_zero => is boolean, default is 0; } } package TestApp::UserCollection; use base qw/Jifty::DBI::Collection/; sub _init { my $self = shift; $self->SUPER::_init(@_); $self->table('users'); } Jifty-DBI-0.77/t/02searches_distinct_values.t0000644000175000017500000001273611417767664020043 0ustar chmrrchmrr#!/usr/bin/env perl -w use strict; use warnings; use File::Spec; use Test::More; BEGIN { require "t/utils.pl" } our (@available_drivers); use constant TESTS_PER_DRIVER => 10; my $total = scalar(@available_drivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @available_drivers ) { 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::UserToGroup', $handle ); ok( $count_us2gs, "init users&groups relations data" ); my $clean_obj = TestApp::UserCollection->new( handle => $handle ); my $users_obj = $clean_obj->clone; is_deeply( $users_obj, $clean_obj, 'after Clone looks the same'); diag "distinct_column_values on clean" if $ENV{'TEST_VERBOSE'}; { is_deeply( [sort $users_obj->distinct_column_values('country')], [qw(br ru us)], "full on non limitted collection" ); is_deeply( [$users_obj->distinct_column_values('country', sort => 'asc')], [qw(br ru us)], "sorting in DB" ); is_deeply( [$users_obj->distinct_column_values('country', sort => 'desc')], [qw(us ru br)], "reverse sorting in DB" ); is_deeply( [$users_obj->distinct_column_values('country', sort => 'desc', max => 2)], [qw(us ru)], "sorting and limitted" ); } cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE table users ( id integer primary key, login varchar(36), country varchar(36) ) }, q{ CREATE table user_to_groups ( id integer primary key, user_id integer, group_id 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), country varchar(36) ) }, q{ CREATE TEMPORARY table user_to_groups ( id integer primary key AUTO_INCREMENT, user_id integer, group_id 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), country varchar(36) ) }, q{ CREATE TEMPORARY table user_to_groups ( id serial primary key, user_id integer, group_id 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), country varchar(36) )", "CREATE SEQUENCE user_to_groups_seq", "CREATE table user_to_groups ( id integer CONSTRAINT user_to_groups_Key PRIMARY KEY, user_id integer, group_id 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 user_to_groups_seq", "DROP table user_to_groups", ] } package TestApp::User; use base qw/Jifty::DBI::Record/; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column login => type is 'varchar(36)'; column country => type is 'varchar(36)'; }; } sub _init { my $self = shift; $self->table('users'); $self->SUPER::_init( @_ ); } sub init_data { return ( [ 'login', 'country' ], [ 'ivan', 'ru' ], [ 'john', 'us' ], [ 'bob', 'us' ], [ 'aurelia', 'br' ], ); } package TestApp::UserCollection; use base qw/Jifty::DBI::Collection/; sub _init { my $self = shift; $self->table('users'); return $self->SUPER::_init( @_ ); } 1; package TestApp::Group; use base qw/Jifty::DBI::Record/; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column name => type is 'varchar(36)'; }; } sub _init { my $self = shift; $self->table('groups'); return $self->SUPER::_init( @_ ); } sub init_data { return ( [ 'name' ], [ 'Developers' ], [ 'Sales' ], [ 'Support' ], ); } package TestApp::GroupCollection; use base qw/Jifty::DBI::Collection/; sub _init { my $self = shift; $self->table('groups'); return $self->SUPER::_init( @_ ); } 1; package TestApp::UserToGroup; use base qw/Jifty::DBI::Record/; BEGIN { use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column user_id => type is 'int(11)'; column group_id => type is 'int(11)'; }; } sub init_data { return ( [ 'group_id', 'user_id' ], # dev group [ 1, 1 ], [ 1, 2 ], [ 1, 4 ], # sales # [ 2, 0 ], # support [ 3, 1 ], ); } package TestApp::UserToGroupCollection; use base qw/Jifty::DBI::Collection/; 1; Jifty-DBI-0.77/lib/0000755000175000017500000000000012246675115012717 5ustar chmrrchmrrJifty-DBI-0.77/lib/Jifty/0000755000175000017500000000000012246675115014004 5ustar chmrrchmrrJifty-DBI-0.77/lib/Jifty/DBI/0000755000175000017500000000000012246675115014402 5ustar chmrrchmrrJifty-DBI-0.77/lib/Jifty/DBI/Record/0000755000175000017500000000000012246675115015620 5ustar chmrrchmrrJifty-DBI-0.77/lib/Jifty/DBI/Record/Memcached.pm0000755000175000017500000001631412016754425020031 0ustar chmrrchmrruse warnings; use strict; package Jifty::DBI::Record::Memcached; use Jifty::DBI::Record; use Jifty::DBI::Handle; use base qw (Jifty::DBI::Record); use Cache::Memcached; =head1 NAME Jifty::DBI::Record::Memcached - records with caching behavior =head1 SYNOPSIS package Myrecord; use base qw/Jifty::DBI::Record::Memcached/; =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 get or load methods without retrieving them from the database. =head1 METHODS =cut use vars qw/$MEMCACHED/; # Function: _init # Type : class ctor # Args : see Jifty::DBI::Record::new # Lvalue : Jifty::DBI::Record::Cachable sub _init () { my ( $self, @args ) = @_; $MEMCACHED ||= Cache::Memcached->new( {$self->memcached_config} ); $self->SUPER::_init(@args); } =head2 load_from_hash Overrides the implementation from L to add support for caching. =cut sub load_from_hash { my $self = shift; # Blow away the primary cache key since we're loading. if ( ref($self) ) { my ( $rvalue, $msg ) = $self->SUPER::load_from_hash(@_); ## Check the return value, if its good, cache it! $self->_store() if ($rvalue); return ( $rvalue, $msg ); } else { $self = $self->SUPER::load_from_hash(@_); ## Check the return value, if its good, cache it! $self->_store() if ( $self->id ); return $self; } } =head2 load_by_cols Overrides the implementation from L to add support for caching. =cut sub load_by_cols { my ( $class, %attr ) = @_; my ($self); if ( ref($class) ) { ( $self, $class ) = ( $class, undef ); } else { $self = $class->new( handle => ( delete $attr{'_handle'} || undef ) ); } ## Generate the cache key my $key = $self->_gen_load_by_cols_key(%attr); if ( $self->_get($key) ) { if ($class) { return $self } else { return ( 1, "Fetched from cache" ) } } ## Fetch from the DB! my ( $rvalue, $msg ) = $self->SUPER::load_by_cols(%attr); ## Check the return value, if its good, cache it! if ($rvalue) { $self->_store(); if ( $key ne $self->_primary_key ) { my $cache_key = $self->_primary_cache_key; $MEMCACHED->add( $key, $cache_key, $self->_cache_config->{'cache_for_sec'} ) if defined $cache_key; $self->{'loaded_by_cols'} = $key; } } if ($class) { return $self } else { return ( $rvalue, $msg ); } } # Function: __set # Type : (overloaded) public instance # Args : see Jifty::DBI::Record::_Set # Lvalue : ? sub __set () { my ( $self, %attr ) = @_; $self->_expire(); return $self->SUPER::__set(%attr); } # Function: _delete # Type : (overloaded) public instance # Args : nil # Lvalue : ? sub __delete () { my ($self) = @_; $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; $MEMCACHED->delete($self->_primary_cache_key); $MEMCACHED->delete($self->{'loaded_by_cols'}) if ($self->{'loaded_by_cols'}); } # Function: _get # Type : private instance # Args : string(cache_key) # Lvalue : 1 # Desc : Get an object from the cache, and make this object that. sub _get () { my ( $self, $cache_key ) = @_; my $data = $MEMCACHED->get($cache_key) or return; # If the cache value is a scalar, that's another key unless (ref $data) { $data = $MEMCACHED->get($data); } unless (ref $data) { return undef; } @{$self}{ keys %$data } = values %$data; # deserialize } # Function: _store # Type : private instance # Args : string(cache_key) # Lvalue : 1 # Desc : Stores this object in the cache. sub _store (\$) { my $self = shift; # Blow away the primary cache key since we're loading. $self->{'_jifty_cache_pkey'} = undef; $MEMCACHED->set( $self->_primary_cache_key, { values => $self->{'values'}, table => $self->table, fetched => $self->{'fetched'}, raw_values => $self->{'raw_values'}, }, $self->_cache_config->{'cache_for_sec'} ); } # Function: _gen_load_by_cols_key # Type : private instance # Args : hash (attr) # Lvalue : 1 # Desc : Takes a perl hash and generates a key from it. sub _gen_load_by_cols_key { my ( $self, %attr ) = @_; my $cache_key = $self->cache_key_prefix . '-'. $self->table() . ':'; my @items; while ( my ( $key, $value ) = each %attr ) { $key ||= '__undef'; $value ||= '__undef'; if ( ref($value) eq "HASH" ) { $value = ( $value->{operator} || '=' ) . $value->{value}; } else { $value = "=" . $value; } push @items, $key.$value; } $cache_key .= join(',',@items); return ($cache_key); } # Function: _primary_cache_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_cache_key { my ($self) = @_; return undef unless ( defined $self->id ); unless ( $self->{'_jifty_cache_pkey'} ) { my $primary_cache_key = $self->cache_key_prefix .'-' .$self->table() . ':'; my @attributes; foreach my $key ( @{ $self->_primary_keys } ) { push @attributes, $key . '=' . $self->SUPER::__value($key); } $primary_cache_key .= join( ',', @attributes ); $self->{'_jifty_cache_pkey'} = $primary_cache_key; } return ( $self->{'_jifty_cache_pkey'} ); } =head2 _cache_config 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 _cache_config { { 'cache_for_sec' => 30 } } =cut sub _cache_config { { 'cache_for_sec' => 180, }; } =head2 memcached_config Returns a hash containing arguments to pass to L during construction. The defaults are like: ( services => [ '127.0.0.1:11211' ], debug => 0, ) You may want to override this method if you want a customized cache configuration: sub memcached_config { ( servers => [ '10.0.0.15:11211', '10.0.0.15:11212', '10.0.0.17:11211', [ '10.0.0.17:11211', 3 ] ], debug => 0, compress_threshold => 10_000, ); } =cut sub memcached_config { servers => ['127.0.0.1:11211'], debug => 0 } =head2 cache_key_prefix Returns the prefix we should prepend to all cache keys. If you're using one memcached for multiple applications, you want this to be different for each application or they might end up mingling data. =cut sub cache_key_prefix { return 'Jifty-DBI'; } 1; __END__ =head1 AUTHOR Matt Knopp =head1 SEE ALSO L, L =cut Jifty-DBI-0.77/lib/Jifty/DBI/Record/Cachable.pm0000755000175000017500000002003111517476345017643 0ustar chmrrchmrrpackage Jifty::DBI::Record::Cachable; use base qw(Jifty::DBI::Record); use Jifty::DBI::Handle; use Cache::Simple::TimedExpiry; use Scalar::Util qw/ blessed /; use strict; use warnings; =head1 NAME Jifty::DBI::Record::Cachable - records with caching behavior =head1 SYNOPSIS package Myrecord; use base qw/Jifty::DBI::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 _setup_cache { my $self = shift; my $cache = shift; $_CACHES{$cache} = Cache::Simple::TimedExpiry->new(); $_CACHES{$cache}->expire_after( $self->_cache_config->{'cache_for_sec'} ); } =head2 flush_cache This class method flushes the _global_ Jifty::DBI::Record::Cachable cache. All caches are immediately expired. =cut sub flush_cache { %_CACHES = (); } sub _key_cache { my $self = shift; my $cache = $self->_handle->dsn . "-KEYS--" . ( $self->{'_class'} || $self->table ); $self->_setup_cache($cache) unless exists( $_CACHES{$cache} ); return ( $_CACHES{$cache} ); } =head2 _flush_key_cache Blow away this record type's key cache =cut sub _flush_key_cache { my $self = shift; my $cache = $self->_handle->dsn . "-KEYS--" . ( $self->{'_class'} || $self->table ); $self->_setup_cache($cache); } sub _record_cache { my $self = shift; my $cache = $self->_handle->dsn . "--" . ( $self->{'_class'} || $self->table ); $self->_setup_cache($cache) unless exists( $_CACHES{$cache} ); return ( $_CACHES{$cache} ); } sub _is_in_transaction { my $self = shift; $Jifty::DBI::Handle::TRANSDEPTH > 0; } =head2 load_from_hash Overrides the implementation from L to add caching. =cut sub load_from_hash { my $self = shift; my ( $rvalue, $msg ); if ( ref($self) ) { # Blow away the primary cache key since we're loading. $self->{'_jifty_cache_pkey'} = undef; ( $rvalue, $msg ) = $self->SUPER::load_from_hash(@_); ## Check the return value, if its good, cache it! $self->_store() if ($rvalue && !$self->_is_in_transaction); return ( $rvalue, $msg ); } else { # Called as a class method; $self = $self->SUPER::load_from_hash(@_); ## Check the return value, if its good, cache it! $self->_store() if ( $self->id && !$self->_is_in_transaction ); return ($self); } } =head2 load_by_cols Overrides the implementation from L to add caching. =cut sub load_by_cols { my ( $class, %attr ) = @_; my ($self); if ( ref($class) ) { ( $self, $class ) = ( $class, undef ); } else { $self = $class->new( handle => ( delete $attr{'_handle'} || undef ) ); } ## Generate the cache key my $alt_key = $self->_gen_record_cache_key(%attr); if ( $self->_fetch($alt_key) ) { if ($class) { return $self } else { return ( 1, "Fetched from cache" ) } } # Blow away the primary cache key since we're loading. $self->{'_jifty_cache_pkey'} = undef; ## Fetch from the DB! my ( $rvalue, $msg ) = $self->SUPER::load_by_cols(%attr); ## Check the return value, if its good, cache it! if ($rvalue && !$self->_is_in_transaction) { ## Only cache the object if its okay to do so. $self->_store(); $self->_key_cache->set( $alt_key => $self->_primary_record_cache_key ); } if ($class) { return $self } else { return ( $rvalue, $msg ); } } # Function: __set # Type : (overloaded) public instance # Args : see Jifty::DBI::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; $self->_record_cache->set( $self->_primary_record_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->_flush_key_cache; } # 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 ) = @_; # If the alternate key is really the primary one my $data = $self->_record_cache->fetch($cache_key); unless ($data) { $cache_key = $self->_key_cache->fetch($cache_key); $data = $self->_record_cache->fetch($cache_key) if $cache_key; } return undef unless ($data); @{$self}{ keys %$data } = values %$data; # deserialize return 1; } #sub __value { # my $self = shift; # my $column = shift; # # # XXX TODO, should we be fetching directly from the cache? # return ( $self->SUPER::__value($column) ); #} # Function: _store # Type : private instance # Args : string(cache_key) # Lvalue : 1 # Desc : Stores this object in the cache. sub _store (\$) { my $self = shift; $self->_record_cache->set( $self->_primary_record_cache_key, { values => $self->{'values'}, table => $self->table, fetched => $self->{'fetched'}, decoded => $self->{'decoded'}, raw_values => $self->{'raw_values'}, } ); } # Function: _gen_record_cache_key # Type : private instance # Args : hash (attr) # Lvalue : 1 # Desc : Takes a perl hash and generates a key from it. sub _gen_record_cache_key { my ( $self, %attr ) = @_; my @cols; while ( my ( $key, $value ) = each %attr ) { unless ( defined $value ) { push @cols, lc($key) . '=__undef'; } elsif ( ref($value) eq "HASH" ) { push @cols, lc($key) . ( $value->{operator} || '=' ) . defined $value->{value} ? $value->{value} : '__undef'; } elsif ( blessed $value and $value->isa('Jifty::DBI::Record') ) { push @cols, lc($key) . '=' . ( $value->id ); } else { push @cols, lc($key) . "=" . $value; } } return ( $self->table() . ':' . join( ',', @cols ) ); } # Function: _fetch_record_cache_key # Type : private instance # Args : nil # Lvalue : 1 sub _fetch_record_cache_key { my ($self) = @_; my $cache_key = $self->_cache_config->{'cache_key'}; return ($cache_key); } # Function: _primary_record_cache_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_record_cache_key { my ($self) = @_; unless ( $self->{'_jifty_cache_pkey'} ) { my @attributes; my %pk = $self->primary_keys; while ( my ( $key, $value ) = each %pk ) { return unless defined $value; push @attributes, lc($key) . '=' . $value; } $self->{'_jifty_cache_pkey'} = $self->table . ':' . join ',', @attributes; } return ( $self->{'_jifty_cache_pkey'} ); } =head2 _cache_config 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 _cache_config { { 'cache_for_sec' => 30 } } =cut sub _cache_config { { 'cache_p' => 1, 'cache_for_sec' => 5, }; } 1; __END__ =head1 AUTHOR Matt Knopp =head1 SEE ALSO L, L =cut Jifty-DBI-0.77/lib/Jifty/DBI/Record/Plugin.pm0000644000175000017500000001331311305565770017415 0ustar chmrrchmrrpackage Jifty::DBI::Record::Plugin; use warnings; use strict; use base qw/Exporter/; =head1 NAME Jifty::DBI::Record::Plugin - Record model mixins for Jifty::DBI =head1 SYNOPSIS # Define a mixin package MyApp::FavoriteColor; use base qw/ Jifty::DBI::Record::Plugin /; # Define which methods you want to put in the host model our @EXPORT = qw( favorite_complementary_color ); use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column favorite_color => type is 'text', label is 'Favorite Color', valid_values are qw/ red green blue yellow /; }; sub favorite_complementary_color { my $self = shift; # whatever host object thing we've mixed with my $color = $self->favorite_color; return $color eq 'red' ? 'green' : $color eq 'green' ? 'red' : $color eq 'blue' ? 'orange' : $color eq 'yellow' ? 'purple' : undef; } # Use the mixin package MyApp::Model::User; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column name => type is 'text', label is 'Name'; }; # Mixins use MyApp::FavoriteColor; sub name_and_color { my $self = shift; my $name = $self->name; my $color = $self->favorite_color; return "The favorite color of $name is $color."; } sub name_and_complementary_color { my $self = shift; my $name = $self->name; my $color = $self->favorite_complementary_color; return "The complement of $name's favorite color is $color."; } =head1 DESCRIPTION By using this package you may provide models that are built from one or more mixins. In fact, your whole table could be defined in the mixins without a single column declared within the model class itself. =head2 MODEL MIXINS To build a mixin, just create a model that inherits from this package, C. Then, add the schema definitions you want inherited. package MyApp::FasterSwallow; use base qw/ Jifty::DBI::Record::Plugin /; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column swallow_type => type is 'text', valid are qw/ african european /, default is 'african'; }; =head3 @EXPORT A mixin may define an C<@EXPORT> variable, which works exactly as advertised in L. That is, given the name of any methods or variable names in the mixin, the host model will gain those methods. our @EXPORT = qw( autocomplete_swallow_type ); sub autocomplete_swallow_type { my $self = shift; my $value = quotemeta(shift); # You should probably find a better way than actually doing this... my @values; push @values, 'african' if 'african' =~ /$value/; push @values, 'european' if 'european' =~ /$value/; return @values; } That way if you have any custom methods you want to throw into the host model, just define them in the mixin and add them to the C<@EXPORT> variable. =head3 register_triggers Your mixin may also want to register triggers for the records to which it will be added. You can do this by defining a method named C: sub register_triggers { my $self = shift; $self->add_trigger( name => 'before_create', callback => \&before_create, abortable => 1, ); } sub before_create { # do something... } See L. =head3 register_triggers_for_column In addition to the general L method described above, the mixin may also implement a C method. This is called for each column in the table. This is primarily helpful for registering the C and C columns. For example: sub register_triggers_for_column { my $self = shift; my $column = shift; return unless $column ne 'updated_on'; $self->add_trigger( name => 'after_set_'.$column, callback => \&touch_update_time, abortable => 1, ); } sub touch_update_time { my $self = shift; $self->set_updated_on(DateTime->now); } This has the additional advantage of being callable when new columns are added to a table while the application is running. This can happen when using database-backed models in Jifty (which, as of this writing, has not been released or made part of the development trunk of Jifty, but is part of the virtual-models branch). See L. =head2 MODELS USING MIXINS To use your model plugin, just use the mixins you want to get columns from. You should still include a schema definition, even if it's empty: package MyApp::Model::User; use Jifty::DBI::Schema; use MyApp::Record schema { }; # Mixins use MyApp::FavoriteColor; use MyApp::FasterSwallow; use Jifty::Plugin::User::Mixin::Model::User; use Jifty::Plugin::Authentication::Password::Mixin::Model::User; =cut sub import { my $self = shift; my $caller = caller; for ($self->columns) { $caller->_init_methods_for_column($_); $caller->COLUMNS->{ $_->name } = $_ unless $_->virtual; } $self->export_to_level(1,undef); if (my $triggers = $self->can('register_triggers') ) { $triggers->($caller) } if (my $triggers_for_column = $self->can('register_triggers_for_column') ) { for my $column (keys %{$caller->_columns_hashref}) { $triggers_for_column->($caller, $column) } } push(@{ $caller->RECORD_MIXINS }, $self) } =head1 SEE ALSO L, L =head1 LICENSE Jifty::DBI is Copyright 2005-2007 Best Practical Solutions, LLC. Jifty is distributed under the same terms as Perl itself. =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Handle/0000755000175000017500000000000012246675115015575 5ustar chmrrchmrrJifty-DBI-0.77/lib/Jifty/DBI/Handle/mysql.pm0000755000175000017500000000573711305565770017317 0ustar chmrrchmrrpackage Jifty::DBI::Handle::mysql; use Jifty::DBI::Handle; @ISA = qw(Jifty::DBI::Handle); use vars qw($VERSION @ISA $DBIHandle $DEBUG); use strict; =head1 NAME Jifty::DBI::Handle::mysql - A mysql specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of L that compensates for some of the idiosyncrasies of MySQL. =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 L 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->fetch_result('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 database_version Returns the mysql version, trimming off any -foo identifier =cut sub database_version { my $self = shift; my $v = $self->SUPER::database_version(@_); $v =~ s/\-.*$//; return ($v); } =head2 case_sensitive Returns undef, since mysql's searches are not case sensitive by default =cut sub case_sensitive { my $self = shift; return (undef); } sub _optimize_joins { my $self = shift; return $self->SUPER::_optimize_joins if $self->database_version =~ /^[34]/; return; } =head2 rename_column ( table => $table, column => $old_column, to => $new_column ) rename column, die if fails =cut sub rename_column { my $self = shift; my %args = ( table => undef, column => undef, to => undef, @_ ); my ($table, $column, $to) = @args{'table', 'column', 'to'}; # XXX, FIXME, TODO: this is stupid parser of CREATE TABLE, this should be something based on # column_info, schema tables and show fields. The closest thing is RT 3.8/etc/upgrade/upgrade-mysql-schema.pl my $create_table = ($self->simple_query("SHOW CREATE TABLE $table")->fetchrow_array)[1]; $create_table =~ /create\s+table\s+\S+\s*\((.*)\)/ims or die "Cannot find 'CREATE TABLE' statement in schema for '$table': $create_table"; $create_table = $1; my ($column_info) = ($create_table =~ /`$column`(.*?)(?:,|$)/i) or die "Cannot find column '$column' in $create_table"; my $sth = $self->simple_query("ALTER TABLE $table CHANGE $column $to $column_info"); die "Cannot rename column '$column' in table '$table' to '$to': ". $self->dbh->errstr unless $sth; return $sth; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO L, L, L =cut Jifty-DBI-0.77/lib/Jifty/DBI/Handle/Oracle.pm0000755000175000017500000001660011551616176017346 0ustar chmrrchmrrpackage Jifty::DBI::Handle::Oracle; use base qw/Jifty::DBI::Handle/; use DBD::Oracle qw(:ora_types ORA_OCI); use vars qw($VERSION $DBIHandle $DEBUG); =head1 NAME Jifty::DBI::Handle::Oracle - An oracle specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of L that compensates for some of the idiosyncrasies of Oracle. =head1 METHODS =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, @_ ); $self->SUPER::connect(%args); $self->dbh->{LongTruncOk} = 1; $self->dbh->{LongReadLen} = 8000; $self->simple_query( "ALTER SESSION set NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'"); return ($DBIHandle); } =head2 database_version Returns value of ORA_OCI constant, see L. =cut sub database_version { return '' . ORA_OCI; } =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, $query_string ); if ( $attribs{'Id'} || $attribs{'id'} ) { $unique_id = ( $attribs{'Id'} ? $attribs{'Id'} : $attribs{'id'} ); } else { $query_string = "SELECT " . $table . "_seq.nextval FROM DUAL"; $sth = $self->simple_query($query_string); if ( !$sth ) { if ($main::debug) { die "Error with $query_string"; } 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 $query_string: " . $self->dbh->errstr; } else { return (undef); } } $self->{'id'} = $unique_id; return ( $self->{'id'} ); #Add Succeded. return the id } =head2 build_dsn PARAMHASH Takes a bunch of parameters: Required: Driver, Database or Host/SID, Optional: Port and RequireSSL Builds a dsn suitable for an Oracle DBI connection =cut sub build_dsn { my $self = shift; my %args = ( driver => undef, database => undef, host => undef, port => undef, sid => undef, requiressl => undef, @_ ); my $dsn = "dbi:$args{'driver'}:"; if ( defined $args{'host'} && $args{'host'} && defined $args{'sid'} && $args{'sid'} ) { $dsn .= "host=$args{'host'};sid=$args{'sid'}"; } else { $dsn .= "$args{'database'}" if ( defined $args{'database'} && $args{'database'} ); } $dsn .= ";port=$args{'port'}" if ( defined $args{'port'} && $args{'port'} ); $dsn .= ";requiressl=1" if ( defined $args{'requiressl'} && $args{'requiressl'} ); $self->{'dsn'} = $dsn; } =head2 blob_params column_NAME column_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 blob_params { my $self = shift; my $column = shift; # Don't assign to key 'value' as it is defined later. return ( { ora_column => $column, ora_type => ORA_CLOB, } ); } =head2 apply_limits 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 apply_limits { 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 distinct_query STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub distinct_query { my $self = shift; my $statementref = shift; my $collection = shift; my $table = $collection->Table; # Wrapp select query in a subselect as Oracle doesn't allow # DISTINCT against CLOB/BLOB column types. if ( $collection->_order_clause =~ /(?{group_by} = [ @{ $collection->{group_by} || [] }, { column => 'id' } ]; local $collection->{order_by} = [ map { my $alias = $_->{alias} || ''; my $column = $_->{column}; if ($column =~ /\W/) { warn "Possible SQL injection in column '$column' in order_by\n"; next; } $alias .= '.' if $alias; ( ( !$alias or $alias eq 'main.' ) and $column eq 'id' ) ? $_ : { %{$_}, column => undef, function => "min($alias$column)" } } @{ $collection->{order_by} } ]; my $group = $collection->_group_clause; my $order = $collection->_order_clause; $$statementref = "SELECT " . $collection->query_columns . " FROM ( SELECT main.id FROM $$statementref $group $order ) distinctquery, $table main WHERE (main.id = distinctquery.id)"; } else { $$statementref = "SELECT " . $collection->query_columns . " FROM ( SELECT DISTINCT main.id FROM $$statementref ) distinctquery, $table main WHERE (main.id = distinctquery.id) "; $$statementref .= $collection->_group_clause; $$statementref .= $collection->_order_clause; } } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO L, L, L =cut Jifty-DBI-0.77/lib/Jifty/DBI/Handle/Sybase.pm0000644000175000017500000000554211305565770017367 0ustar chmrrchmrrpackage Jifty::DBI::Handle::Sybase; use Jifty::DBI::Handle; @ISA = qw(Jifty::DBI::Handle); use vars qw($VERSION @ISA $DBIHandle $DEBUG); use strict; =head1 NAME Jifty::DBI::Handle::Sybase -- a Sybase specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of L that compensates for some of the idiosyncrasies of Sybase. =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 L 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->fetch_result('SELECT @@identity'); # TODO: Propagate Class::ReturnValue up here. unless ( $row[0] ) { return (undef); } $self->{'id'} = $row[0]; } return ( $self->{'id'} ); } =head2 database_version return the database version, trimming off any -foo identifier =cut sub database_version { my $self = shift; my $v = $self->SUPER::database_version(); $v =~ s/\-(.*)$//; return ($v); } =head2 case_sensitive Returns undef, since Sybase's searches are not case sensitive by default =cut sub case_sensitive { my $self = shift; return (1); } # sub apply_limits { # my $self = shift; # my $statementref = shift; # my $per_page = shift; # my $first = shift; # # } =head2 distinct_query STATEMENTREF Takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub distinct_query { my $self = shift; my $statementref = shift; my $collection = shift; my $table = $collection->table; if ( $collection->_order_clause =~ /(?_group_clause; $$statementref .= $collection->_order_clause; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO L, L, L =cut Jifty-DBI-0.77/lib/Jifty/DBI/Handle/ODBC.pm0000644000175000017500000000333611305565770016647 0ustar chmrrchmrrpackage Jifty::DBI::Handle::ODBC; use Jifty::DBI::Handle; @ISA = qw(Jifty::DBI::Handle); use vars qw($VERSION @ISA $DBIHandle $DEBUG); use strict; =head1 NAME Jifty::DBI::Handle::ODBC - An ODBC specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of L that compensates for some of the idiosyncrasies of ODBC. =head1 METHODS =cut =head2 case_sensitive Returns a false value. =cut sub case_sensitive { my $self = shift; return (undef); } =head2 build_dsn =cut sub build_dsn { my $self = shift; my %args = ( driver => undef, database => undef, host => undef, port => undef, @_ ); $args{dbname} ||= delete $args{database}; my $dsn = "dbi:$args{driver}:$args{dbname}"; $dsn .= ";host=$args{'host'}" if $args{'host'}; $dsn .= ";port=$args{'port'}" if $args{'port'}; $self->{'dsn'} = $dsn; } =head2 apply_limits =cut sub apply_limits { 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 distinct_query =cut sub distinct_query { my $self = shift; my $statementref = shift; my $collection = shift; $$statementref = "SELECT main.* FROM $$statementref"; $$statementref .= $collection->_group_clause; $$statementref .= $collection->_order_clause; } =head2 encoding =cut sub encoding { } 1; __END__ =head1 AUTHOR Audrey Tang C =head1 SEE ALSO L, L, L =cut Jifty-DBI-0.77/lib/Jifty/DBI/Handle/SQLite.pm0000644000175000017500000001054211517476345017302 0ustar chmrrchmrr package Jifty::DBI::Handle::SQLite; use Jifty::DBI::Handle; @ISA = qw(Jifty::DBI::Handle); use vars qw($VERSION @ISA $DBIHandle $DEBUG); use strict; =head1 NAME Jifty::DBI::Handle::SQLite -- A SQLite specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of Jifty::DBI::Handle that compensates for some of the idiosyncrasies of SQLite. =head1 METHODS =head2 database_version Returns the version of the SQLite library which is used, e.g., "2.8.0". SQLite can only return short variant. =cut sub database_version { 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 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->dbh->func('last_insert_rowid'); warn "$self no row id returned on row creation" unless ( $self->{'id'} ); return ( $self->{'id'} ); #Add Succeded. return the id } =head2 case_sensitive Returns 1, since SQLite's searches are case sensitive by default. Note, however, SQLite's C operator is case Isensitive. =cut sub case_sensitive { my $self = shift; return (1); } =head2 distinct_count STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result count =cut sub distinct_count { my $self = shift; my $statementref = shift; # Wrapper select query in a subselect as Oracle doesn't allow # DISTINCT against CLOB/BLOB column types. $$statementref = "SELECT count(*) FROM (SELECT DISTINCT main.id FROM $$statementref )"; } sub _make_clause_case_insensitive { my $self = shift; my $column = shift; my $operator = shift; my $value = shift; return ($column, $operator, $value) unless $self->_case_insensitivity_valid( $column, $operator, $value ); return("$column COLLATE NOCASE", $operator, $value); } =head2 rename_column ( table => $table, column => $old_column, to => $new_column ) rename column =cut sub rename_column { my $self = shift; my %args = ( table => undef, column => undef, to => undef, @_ ); my $table = $args{'table'}; # Convert columns my ($schema) = $self->fetch_result( "SELECT sql FROM sqlite_master WHERE tbl_name = ? AND type = ?", $table, 'table', ); $schema =~ s/(.*create\s+table\s+)\S+(.*?\(\s*)//i or die "Cannot find 'CREATE TABLE' statement in schema for '$table': $schema"; my $new_table = join( '_', $table, 'new', $$ ); my $new_create_clause = "$1$new_table$2"; my @column_info = ( split /,/, $schema ); my @column_names = map { /^\s*(\S+)/ ? $1 : () } @column_info; s/^(\s*)\b\Q$args{column}\E\b/$1$args{to}/i for @column_info; my $new_schema = $new_create_clause . join( ',', @column_info ); my $copy_columns = join( ', ', map { ( lc($_) eq lc( $args{column} ) ) ? "$_ AS $args{to}" : $_ } @column_names ); # Convert indices my $indice_sth = $self->simple_query( "SELECT sql FROM sqlite_master WHERE tbl_name = ? AND type = ?", $table, 'index' ); my @indice_sql; while ( my ($index) = $indice_sth->fetchrow_array ) { $index =~ s/^(.*\(.*)\b\Q$args{column}\E\b/$1$args{to}/i; push @indice_sql, $index; } $indice_sth->finish; # Run the conversion SQLs $self->begin_transaction; $self->simple_query($new_schema); $self->simple_query("INSERT INTO $new_table SELECT $copy_columns FROM $table"); $self->simple_query("DROP TABLE $table"); $self->simple_query("ALTER TABLE $new_table RENAME TO $table"); $self->simple_query($_) for @indice_sql; $self->commit; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO perl(1), Jifty::DBI =cut Jifty-DBI-0.77/lib/Jifty/DBI/Handle/Informix.pm0000644000175000017500000000576111502103765017726 0ustar chmrrchmrrpackage Jifty::DBI::Handle::Informix; use Jifty::DBI::Handle; @ISA = qw(Jifty::DBI::Handle); use vars qw($VERSION @ISA $DBIHandle $DEBUG); use strict; =head1 NAME Jifty::DBI::Handle::Informix - An Informix specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of Jifty::DBI::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 case_sensitive Returns 1, since Informix's searches are case sensitive by default =cut sub case_sensitive { my $self = shift; return (1); } =head2 apply_limits 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 apply_limits { 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; } } =head2 disconnect Disconnects and removes the reference to the handle for Informix. =cut sub disconnect { my $self = shift; if ( $self->dbh ) { my $status = $self->dbh->disconnect(); $self->dbh(undef); return $status; } else { return; } } =head2 distinct_query STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub distinct_query { my $self = shift; my $statementref = shift; my $collection = shift; my $table = $collection->table; if ( $collection->_order_clause =~ /(?_group_clause; $$statementref .= $collection->_order_clause; } 1; __END__ =head1 AUTHOR Oliver Tappe, oliver@akso.de =head1 SEE ALSO perl(1), Jifty::DBI =cut Jifty-DBI-0.77/lib/Jifty/DBI/Handle/mysqlPP.pm0000644000175000017500000000073011305565770017540 0ustar chmrrchmrrpackage Jifty::DBI::Handle::mysqlPP; use Jifty::DBI::Handle::mysql; @ISA = qw(Jifty::DBI::Handle::mysql); use vars qw($VERSION @ISA $DBIHandle $DEBUG); use strict; 1; __END__ =head1 NAME Jifty::DBI::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 Jifty::DBI::Handle::mysql class. =head1 AUTHOR =head1 SEE ALSO Jifty::DBI::Handle::mysql =cut Jifty-DBI-0.77/lib/Jifty/DBI/Handle/Pg.pm0000755000175000017500000001507312016754425016507 0ustar chmrrchmrrpackage Jifty::DBI::Handle::Pg; use strict; use vars qw($VERSION @ISA $DBIHandle $DEBUG); use base qw(Jifty::DBI::Handle); use strict; =head1 NAME Jifty::DBI::Handle::Pg - A Postgres specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of L 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, returns a database handle. =cut sub connect { my $self = shift; $self->SUPER::connect(@_); $self->simple_query("SET TIME ZONE 'GMT'"); $self->simple_query("SET DATESTYLE TO 'ISO'"); $self->auto_commit(1); return ($DBIHandle); } =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 ); unless ($sth) { return ($sth); } if ( $args{'id'} || $args{'Id'} ) { $self->{'id'} = $args{'id'} || $args{'Id'}; return ( $self->{'id'} ); } my $sequence_name = $self->id_sequence_name($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 id_sequence_name TABLE Takes a TABLE name and returns the name of the sequence of the primary key for that table. =cut sub id_sequence_name { my $self = shift; my $table = shift; return $self->{'_sequences'}{$table} if ( exists $self->{'_sequences'}{$table} ); #Lets 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 blob_params column_NAME column_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 Postgres implementation only supports BYTEA types. =cut sub blob_params { my $self = shift; my $name = shift; my $type = shift; # Don't assign to key 'value' as it is defined later. return ( { pg_type => DBD::Pg::PG_BYTEA() } ) if $type =~ /^(?:blob|bytea)$/; return ( {} ); } =head2 apply_limits 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 apply_limits { 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 _make_clause_case_insensitive column operator VALUE Takes a column, operator and value. performs the magic necessary to make your database treat this clause as case insensitive. Returns a column operator value triple. =cut sub _make_clause_case_insensitive { my $self = shift; my $column = shift; my $operator = shift; my $value = shift; if ( $self->_case_insensitivity_valid( $column, $operator, $value ) ) { $column = "LOWER($column)"; if ( $operator =~ /^(IN|=)$/i and ref($value) eq 'ARRAY' ) { $value = [ map {"LOWER($_)"} @$value ]; } else { $value = "LOWER($value)"; } } return ( $column, $operator, $value ); } =head2 distinct_query STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub distinct_query { my $self = shift; my $statementref = shift; my $collection = shift; my $table = $collection->table; if (grep { ( defined $_->{'alias'} and $_->{'alias'} ne 'main' ) || defined $_->{'function'} } @{ $collection->order_by } ) { # If we are ordering by something not in 'main', we need to GROUP # BY and adjust the ORDER_BY accordingly local $collection->{group_by} = [ @{ $collection->{group_by} || [] }, { column => 'id' } ]; local $collection->{order_by} = [ map { my $alias = $_->{alias} || ''; my $column = $_->{column}; my $order = $_->{order}; if ($column =~ /\W/) { warn "Possible SQL injection in column '$column' in order_by\n"; next; } $alias .= '.' if $alias; ( ( !$alias or $alias eq 'main.' ) and $column eq 'id' ) ? $_ : { %{$_}, column => undef, function => ($order =~ /^des/i ? 'MAX':'MIN'). "($alias$column)" } } @{ $collection->{order_by} } ]; my $group = $collection->_group_clause; my $order = $collection->_order_clause; $$statementref = "SELECT " . $collection->query_columns . " FROM ( SELECT main.id FROM $$statementref $group $order ) distinctquery, $table main WHERE (main.id = distinctquery.id)"; } else { $$statementref = "SELECT DISTINCT " . $collection->query_columns . " FROM $$statementref"; $$statementref .= $collection->_group_clause; $$statementref .= $collection->_order_clause; } } =head2 canonical_true The canonical true value in Postgres is 't'. =cut sub canonical_true { 't' } =head2 canonical_false The canonical false value in Postgres is 'f'. =cut sub canonical_false { 'f' } 1; __END__ =head1 SEE ALSO L, L, L =cut Jifty-DBI-0.77/lib/Jifty/DBI/HasFilters.pm0000644000175000017500000000423711555571141017006 0ustar chmrrchmrrpackage Jifty::DBI::HasFilters; use warnings; use strict; use base qw/Class::Accessor::Fast/; __PACKAGE__->mk_accessors(qw/ input_filters output_filters filters /); =head1 NAME Jifty::DBI::HasFilters - abstract class for objects that has filters =head1 SYNOPSIS my $record = Jifty::DBI::Record->new(...); $record->input_filters( 'Jifty::DBI::Filter::Truncate', 'Jifty::DBI::Filter::utf8' ); my @filters = $record->output_filters; =head1 DESCRIPTION This abstract class provide generic interface for setting and getting input and output data filters for L objects. You shouldn't use it directly, but L, L and L classes inherit this interface. =head1 METHODS =head2 input_filters Returns array of the input filters, if arguments list is not empty then set input filter. =cut sub input_filters { my $self = shift; if (@_) { # setting my @values = map { UNIVERSAL::isa( $_, 'ARRAY' ) ? @$_ : $_ } @_; $self->{input_filters} = \@values; return @values; } return @{ $self->{input_filters} || [] }; } =head2 output_filters Deals similar with list of output filters, but unless you defined own list returns reversed list of the input filters. In common situation you don't need to define own list of output filters, but use this method to get default list based on the input list. =cut sub output_filters { my $self = shift; if (@_) { # setting my @values = map { UNIVERSAL::isa( $_, 'ARRAY' ) ? @$_ : $_ } @_; $self->{output_filters} = \@values; return @values; } my $values = $self->{output_filters}; return @$values if $values && @$values; return reverse $self->input_filters; } =head2 filters FILTERS Sets the input and output filters at the same time. Returns a hash, with keys C and C, whose values are array references to the respective lists. =cut sub filters { my $self = shift; return { output => $self->output_filters(@_), input => $self->input_filters(@_) }; } =head1 SEE ALSO L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/0000755000175000017500000000000012246675115015627 5ustar chmrrchmrrJifty-DBI-0.77/lib/Jifty/DBI/Filter/Boolean.pm0000644000175000017500000000411611502103765017535 0ustar chmrrchmrrpackage Jifty::DBI::Filter::Boolean; use warnings; use strict; use base 'Jifty::DBI::Filter'; use constant TRUE_VALUES => qw(1 t true y yes TRUE); use constant FALSE_VALUES => ('', qw(0 f false n no FALSE)); sub _is_true { my $self = shift; my $value = shift; no warnings 'uninitialized'; for ($self->TRUE_VALUES, map { "'$_'" } $self->TRUE_VALUES) { return 1 if $value eq $_; } return 0; } sub _is_false { my $self = shift; my $value = shift; return 1 if not defined $value; for ($self->FALSE_VALUES, map { "'$_'" } $self->FALSE_VALUES) { return 1 if $value eq $_; } return 0; } =head1 NAME Jifty::DBI::Filter::Boolean - Encodes booleans =head1 DESCRIPTION =head2 decode Transform the value into 1 or 0 so Perl's concept of the value agrees with the database's concept of the value. (For example, 't' and 'f' might be used in the database, but 'f' is true in Perl) =cut sub decode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref; if ($self->_is_true($$value_ref)) { $$value_ref = 1; } elsif ($self->_is_false($$value_ref)) { $$value_ref = 0; } else { $self->handle->log("The value '$$value_ref' does not look like a boolean. Defaulting to false."); $$value_ref = 0; } } =head2 encode Transform the value to the canonical true or false value as expected by the database. =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return unless defined($$value_ref) or $self->column->mandatory; return if uc($$value_ref||'') eq "NULL" and not $self->column->mandatory; if ($self->_is_true($$value_ref)) { $$value_ref = $self->handle->canonical_true; } elsif ($self->_is_false($$value_ref)) { $$value_ref = $self->handle->canonical_false; } else { $self->handle->log("The value '$$value_ref' does not look like a boolean. Defaulting to false."); $$value_ref = $self->handle->canonical_false; } } =head1 SEE ALSO L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/Storable.pm0000644000175000017500000000215711305565770017745 0ustar chmrrchmrrpackage Jifty::DBI::Filter::Storable; use warnings; use strict; use base qw|Jifty::DBI::Filter|; use Storable (); =head1 NAME Jifty::DBI::Filter::Storable - Encodes arbitrary data using Storable =head1 DESCRIPTION This filter allows you to store arbitrary Perl data structures in a column of type 'blob', using L to serialize them. =head2 encode If value is defined, then encodes it using L. Does nothing if value is not defined. =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref; $Storable::Deparse = 1; $$value_ref = Storable::nfreeze($value_ref); } =head2 decode If value is defined, then decodes it using L, otherwise does nothing. =cut sub decode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref; # Storable doesn't take Unicode strings. Encode::_utf8_off($$value_ref); local $@; $Storable::Eval = 1; $$value_ref = eval { ${ Storable::thaw($$value_ref) } }; } =head1 SEE ALSO L, L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/Duration.pm0000644000175000017500000000242611305565770017756 0ustar chmrrchmrrpackage Jifty::DBI::Filter::Duration; use warnings; use strict; use base qw|Jifty::DBI::Filter|; use Time::Duration qw(); use Time::Duration::Parse qw(); =head1 NAME Jifty::DBI::Filter::Duration - Encodes time durations =head1 DESCRIPTION =head2 encode If value is defined, then encode it using L, otherwise do nothing. If the value can't be parsed, then set it to undef. =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref and length $$value_ref; my ($parsed) = eval { Time::Duration::Parse::parse_duration($$value_ref) }; if ( not $@ ) { $$value_ref = $parsed; return 1; } else { $$value_ref = undef; return; } } =head2 decode If value is defined, then decode it using L and L, otherwise do nothing. =cut sub decode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref and length $$value_ref and $$value_ref =~ /^\s*\d+\s*$/; $$value_ref = Time::Duration::concise(Time::Duration::duration_exact($$value_ref)); } =head1 SEE ALSO L, L, L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/utf8.pm0000644000175000017500000000311411502103765017041 0ustar chmrrchmrr use strict; use warnings; package Jifty::DBI::Filter::utf8; use base qw/Jifty::DBI::Filter/; use Encode (); =head1 NAME Jifty::DBI::Filter::utf8 - Jifty::DBI UTF-8 data filter =head1 DESCRIPTION This filter allow you to check that you operate with valid UTF-8 data. Usage as type specific filter is recommended. =head1 METHODS =head2 encode Method always unset UTF-8 flag on the value, but if value doesn't have flag then method checks value for malformed UTF-8 data and stop on the first bad code. =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return undef unless ( defined($$value_ref) ); if ( Encode::is_utf8($$value_ref) ) { $$value_ref = Encode::encode_utf8($$value_ref); } else { # if value has no utf8 flag but filter on the stack # we do double encoding, and stop on the first bad characters # with FB_QUIET fallback schema. We this schema because we # don't want data grow $$value_ref = Encode::encode_utf8( Encode::decode_utf8( $$value_ref, Encode::FB_QUIET ) ); } return 1; } =head2 decode Checks whether value is correct UTF-8 data or not and substitute all malformed data with the C<0xFFFD> code point. Always set UTF-8 flag on the value. =cut sub decode { my $self = shift; my $value_ref = $self->value_ref; return undef unless ( defined($$value_ref) ); unless ( Encode::is_utf8($$value_ref) ) { $$value_ref = Encode::decode_utf8($$value_ref); } return 1; } 1; __END__ =head1 SEE ALSO L, L =cut Jifty-DBI-0.77/lib/Jifty/DBI/Filter/Date.pm0000644000175000017500000000214011305565770017037 0ustar chmrrchmrrpackage Jifty::DBI::Filter::Date; use warnings; use strict; use base qw|Jifty::DBI::Filter::DateTime|; use constant _time_zone => 'floating'; use constant _strptime => '%Y-%m-%d'; use constant date_only => 1; =head1 NAME Jifty::DBI::Filter::Date - DateTime object wrapper around date columns =head1 DESCRIPTION This filter allow you to work with DateTime objects that represent "Dates", store everything in the database in GMT and not hurt yourself badly when you pull them out and put them in repeatedly. =head2 encode If value is a DateTime object then move it into a "floating" timezone and expand it into ISO 8601 format C. By storing it in the database as a floating timezone, it doesn't matter if the user's desired timezone changes between lookups Does nothing if value is not defined or is a string. =cut =head2 decode If we're loading something from a column that doesn't specify times, then it's loaded into a floating timezone. If value is defined then converts it into DateTime object otherwise do nothing. =cut =head1 SEE ALSO L, L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/base64.pm0000644000175000017500000000213311417767664017262 0ustar chmrrchmrrpackage Jifty::DBI::Filter::base64; use warnings; use strict; use base qw|Jifty::DBI::Filter|; use Encode qw(encode_utf8 is_utf8); use MIME::Base64 (); =head1 NAME Jifty::DBI::Filter::base64 - Encodes data as base64 =head1 DESCRIPTION This filter allow you to store arbitrary data in a column of type 'text'. =head2 encode If value is defined, then encodes it using L after passing it through L. Does nothing if value is not defined. =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref; $$value_ref = MIME::Base64::encode_base64( is_utf8($$value_ref) ? encode_utf8($$value_ref) : $$value_ref ); return 1; } =head2 decode If value is defined, then decodes it using L, otherwise do nothing. =cut sub decode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref; $$value_ref = MIME::Base64::decode_base64($$value_ref); } =head1 SEE ALSO L, L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/SaltHash.pm0000644000175000017500000000340011305565770017671 0ustar chmrrchmrrpackage Jifty::DBI::Filter::SaltHash; use warnings; use strict; use base qw|Jifty::DBI::Filter|; use Digest::MD5 qw(md5_hex); =head1 NAME Jifty::DBI::Filter::SaltHash - salts and hashes a value before storing it =head1 DESCRIPTION This filter will generate a random 4-byte salt, and then MD5 the given value with the salt appended to the value. It will store the hash and the salt in the database, and return a data structure that contains both on decode. The salt and hash are stored in hexadecimal in the database, so that you can put them in a text field. This filter is intended for storing passwords in a database. =head2 encode Generate a random 4-byte salt, MD5 the value with the salt (encoded to hexadecimal) appended to it, and store both in the database. =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref; my $salt = generate_salt(); $$value_ref = md5_hex($$value_ref, $salt) . $salt; } =head2 generate_salt Return a random 4-byte salt value, encoded as an 8-character hex string. =cut sub generate_salt { my $salt; $salt .= unpack('H2',chr(int rand(255))) for(1..4); return $salt; } =head2 decode Return an arrayref of (hash, salt), both as hex strings. To test whether a provided value is the same one originally encoded, use $hash eq md5_hex($value . $salt); =cut sub decode { my $self = shift; my $value_ref = $self->value_ref; return unless $$value_ref; # This should never happen, but just to be safe unless(length($$value_ref) == (8 + 32)) { $$value_ref = [undef, undef]; } else { $$value_ref = [unpack("A32A8", $$value_ref)]; } return 1; } =head1 SEE ALSO L, L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/DateTime.pm0000644000175000017500000000745712045412313017660 0ustar chmrrchmrrpackage Jifty::DBI::Filter::DateTime; use warnings; use strict; use base qw|Jifty::DBI::Filter Class::Data::Inheritable|; use DateTime (); use DateTime::Format::ISO8601 (); use DateTime::Format::Strptime (); use Carp (); use constant _time_zone => 'UTC'; use constant _strptime => '%Y-%m-%d %H:%M:%S'; use constant _parser => DateTime::Format::ISO8601->new(); use constant date_only => 0; =head1 NAME Jifty::DBI::Filter::DateTime - DateTime object wrapper around date columns =head1 DESCRIPTION This filter allow you to work with DateTime objects instead of plain text dates. If the column type is "date", then the hour, minute, and second information is discarded when encoding. Both input and output will always be coerced into UTC (or, in the case of Dates, the Floating timezone) for consistency. =head2 formatter This is an instance of the DateTime::Format object used for inflating the string in the database to a DateTime object. By default it is a L object that uses the C<_strptime> method as its pattern. You can use the _formatter classdata storage as a cache so you don't need to re-instantiate your format object every C. =cut __PACKAGE__->mk_classdata("_formatter"); sub formatter { my $self = shift; if ( not $self->_formatter or $self->_formatter->pattern ne $self->_strptime ) { $self->_formatter(DateTime::Format::Strptime->new(pattern => $self->_strptime)); } return $self->_formatter; } =head2 encode If value is DateTime object then converts it into ISO format C. Does nothing if value is not defined. Sets the value to undef if the value is a string and doesn't match an ISO date (at least). =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return if !defined $$value_ref; if ( ! UNIVERSAL::isa( $$value_ref, 'DateTime' )) { if ($$value_ref !~ /^\d{4}[ -]?\d{2}[ -]?\d{2}/) { $$value_ref = undef; } return undef; } return unless $$value_ref; if (my $tz = $self->_time_zone) { $$value_ref = $$value_ref->clone; $$value_ref->set_time_zone($tz); } $$value_ref = $$value_ref->DateTime::strftime($self->_strptime); return 1; } =head2 decode If value is defined then converts it into DateTime object otherwise do nothing. =cut sub decode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref; # XXX: Looks like we should use special modules for parsing DT because # different MySQL versions can return DT in different formats(none strict ISO) # Pg has also special format that depends on "european" and # server time_zone, by default ISO # other DBs may have own formats(Interbase for example can be forced to use special format) # but we need Jifty::DBI::Handle here to get DB type my $str = join('T', split ' ', $$value_ref, 2); # The ISO8601 parser accepts 2012-11-04T12:34:56+00 # and 2012-11-04T12:34:56.789+00:00 # but not 2012-11-04T12:34:56.789+00 # Postgres returns sub-second times as the last one; append ":00" to # change it into the acceptable second option. $str .= ":00" if $str =~ /\d\.\d+[+-]\d\d$/; my $dt; eval { $dt = $self->_parser->parse_datetime($str) }; if ($@) { # if datetime can't decode this, scream loudly with a useful error message Carp::cluck("Unable to decode $str: $@"); return; } return if !$dt; my $tz = $self->_time_zone; $dt->set_time_zone($tz) if $tz; if ($self->date_only) { $dt->set_hour(0); $dt->set_minute(0); $dt->set_second(0); } $dt->set_formatter($self->formatter); $$value_ref = $dt; } =head1 SEE ALSO L, L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/Time.pm0000644000175000017500000000210011305565770017054 0ustar chmrrchmrrpackage Jifty::DBI::Filter::Time; use warnings; use strict; use base qw|Jifty::DBI::Filter::DateTime|; use constant _time_zone => 'floating'; use constant _strptime => '%H:%M:%S'; =head1 NAME Jifty::DBI::Filter::Date - DateTime object wrapper around date columns =head1 DESCRIPTION This filter allow you to work with DateTime objects that represent "Dates", store everything in the database in GMT and not hurt yourself badly when you pull them out and put them in repeatedly. =head2 encode If value is a DateTime object then move it into a "floating" timezone and expand it into ISO 8601 format C. By storing it in the database as a floating timezone, it doesn't matter if the user's desired timezone changes between lookups Does nothing if value is not defined or is a string. =cut =head2 decode If we're loading something from a column that doesn't specify times, then it's loaded into a floating timezone. If value is defined then converts it into DateTime object otherwise do nothing. =cut =head1 SEE ALSO L, L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/YAML.pm0000644000175000017500000000473611305565770016741 0ustar chmrrchmrruse strict; use warnings; package Jifty::DBI::Filter::YAML; use base qw/ Jifty::DBI::Filter /; my ($Dump, $Load); eval "use YAML::Syck ()"; if ($@) { # We don't actually need to "use", which is checked at compile # time and would cause error when YAML is not installed. # Or, eval this, too? require YAML; $Dump = \&YAML::Dump; $Load = \&YAML::Load; } else { $Dump = \&YAML::Syck::Dump; $Load = \&YAML::Syck::Load; } =head1 NAME Jifty::DBI::Filter::YAML - This filter stores arbitrary Perl via YAML =head1 SYNOPSIS use Jifty::DBI::Record schema { column my_data => type is 'text', filters are qw/ Jifty::DBI::Filter::YAML /; }; my $thing = __PACKAGE__->new; $thing->create( my_data => { foo => 'bar', baz => [ 1, 2, 3 ] } ); my $my_data = $thing->my_data; while (my ($key, $value) = %$my_data) { # do something... } =head1 DESCRIPTION This filter provides the ability to store arbitrary data structures into a database column using L. This is very similar to the L filter except that the L format remains human-readable in the database. You can store virtually any Perl data, scalar, hash, array, or object into the database using this filter. In addition, YAML (at least the storage of scalars, hashes, and arrays) is compatible with data structures written in other languages, so you may store or read data between applications written in different languages. =head1 METHODS =head2 encode This method is used to encode the Perl data structure into YAML formatted text. =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref; $$value_ref = $Dump->($$value_ref); } =head2 decode This method is used to decode the YAML formatted text from the database into the Perl data structure. =cut sub decode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref; $$value_ref = $Load->($$value_ref); } =head1 IMPLEMENTATION This class will attempt to use L if it is available and then fall back upon L. This has been done because the Syck library is written in C and is considerably faster. =head1 SEE ALSO L, L, L =head1 AUTHOR Andrew Sterling Hanenkamp Ehanenkamp@cpan.orgE =head1 LICENSE This program is free software and may be modified or distributed under the same terms as Perl itself. =cut 1 Jifty-DBI-0.77/lib/Jifty/DBI/Filter/Truncate.pm0000644000175000017500000000321411502103765017741 0ustar chmrrchmrr use strict; use warnings; package Jifty::DBI::Filter::Truncate; use base qw/Jifty::DBI::Filter/; use Encode (); =head1 NAME Jifty::DBI::Filter::Truncate - Filter used to enforce max_length column trait =head1 DESCRIPTION You do not need to use this filter explicitly. This filter is used internally to enforce the L restrictions on columns: column name => type is 'text', max_length is 10; In this case, the filter would be automatically added to the column named C and any value put into the column longer than 10 characters would be truncated to 10 characters. =head1 METHODS =head2 encode This method performs the work of performing truncation, when necessary. =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return undef unless ( defined($$value_ref) ); my $column = $self->column(); my $truncate_to; if ( $column->max_length && !$column->is_numeric ) { $truncate_to = $column->max_length; } elsif ( $column->type && $column->type =~ /char\((\d+)\)/ ) { $truncate_to = $1; } return unless ($truncate_to); # don't need to truncate my $utf8 = Encode::is_utf8($$value_ref); { use bytes; $$value_ref = substr( $$value_ref, 0, $truncate_to ); } if ($utf8) { # return utf8 flag back, but use Encode::FB_QUIET because # we could broke tail char $$value_ref = Encode::decode_utf8( $$value_ref, Encode::FB_QUIET ); } } =head1 LICENSE Jifty::DBI is Copyright 2005-2007 Best Practical Solutions, LLC. Jifty::DBI is distributed under the same terms as Perl itself. =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/Filter/URI.pm0000644000175000017500000000153311305565770016626 0ustar chmrrchmrr#!/usr/bin/env perl package Jifty::DBI::Filter::URI; use strict; use warnings; use base 'Jifty::DBI::Filter'; use URI; =head1 NAME Jifty::DBI::Filter::URI - Encodes uniform resource identifiers =head1 DESCRIPTION =head2 encode If the value is a L, encode it to its string form. Otherwise, do nothing. =cut sub encode { my $self = shift; my $value_ref = $self->value_ref; return unless ref $$value_ref and $$value_ref->isa('URI'); $$value_ref = $$value_ref->as_string; return 1; } =head2 decode If value is defined, then decode it using L, otherwise do nothing. =cut sub decode { my $self = shift; my $value_ref = $self->value_ref; return unless defined $$value_ref and length $$value_ref; $$value_ref = URI->new($$value_ref); } =head1 SEE ALSO L, L =cut 1; Jifty-DBI-0.77/lib/Jifty/DBI/SchemaGenerator.pm0000644000175000017500000002373512115431272020006 0ustar chmrrchmrruse strict; use warnings; package Jifty::DBI::SchemaGenerator; use base qw(Class::Accessor::Fast); use DBIx::DBSchema; use DBIx::DBSchema::Column; use DBIx::DBSchema::Table; use Class::ReturnValue; use version; our $VERSION = '0.01'; # Public accessors __PACKAGE__->mk_accessors(qw(handle)); # Internal accessors: do not use from outside class __PACKAGE__->mk_accessors(qw(_db_schema)); =head1 NAME Jifty::DBI::SchemaGenerator - Generate a table schema from Jifty::DBI records =head1 DESCRIPTION This module turns a Jifty::Record object into an SQL schema for your chosen database. At the moment, your choices are MySQL, SQLite, or PostgreSQL. Oracle might also work right, though it's untested. =head1 SYNOPSIS =head2 The Short Answer See below for where we get the $handle and $model variables. use Jifty::DBI::SchemaGenerator; ... my $s_gen = Jifty::DBI::SchemaGenerator->new( $handle ); $s_gen->add_model($model); my @statements = $s_gen->create_table_sql_statements; print join("\n", @statements, ''); ... =head2 The Long Version See L for details about the first two parts. =over =item MyModel package MyModel; # lib/MyModel.pm use warnings; use strict; use base qw(Jifty::DBI::Record); # your custom code goes here. 1; =item MyModel::Schema package MyModel::Schema; # lib/MyModel/Schema.pm use warnings; use strict; use Jifty::DBI::Schema; column foo => type is 'text'; column bar => type is 'text'; 1; =item myscript.pl #!/usr/bin/env perl # myscript.pl use strict; use warnings; use Jifty::DBI::SchemaGenerator; use Jifty::DBI::Handle; use MyModel; use MyModel::Schema; my $handle = Jifty::DBI::Handle->new(); $handle->connect( driver => 'SQLite', database => 'testdb', ); my $model = MyModel->new($handle); my $s_gen = Jifty::DBI::SchemaGenerator->new( $handle ); $s_gen->add_model($model); # here's the basic point of this module: my @statements = $s_gen->create_table_sql_statements; print join("\n", @statements, ''); # this part is directly from Jifty::Script::Schema::create_all_tables() $handle->begin_transaction; for my $statement (@statements) { my $ret = $handle->simple_query($statement); $ret or die "error creating a table: " . $ret->error_message; } $handle->commit; =back =head1 CONFIGURATION AND ENVIRONMENT Requires no configuration files or environment variables. =head1 DEPENDENCIES Class::Accessor::Fast DBIx::DBSchema Class::ReturnValue =head1 METHODS =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; } =head2 add_model MODEL Adds a new model class to the SchemaGenerator. Model should be an object which is an instance of C or a subclass thereof. It may also be a string which is the name of such a class/subclass; in the latter case, C will instantiate an object of the class. 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 add_model { my $self = shift; my $model = shift; # $model could either be a (presumably unfilled) object of a subclass of # Jifty::DBI::Record, or it could be the name of such a subclass. unless ( ref $model and UNIVERSAL::isa( $model, 'Jifty::DBI::Record' ) ) { my $new_model; eval { $new_model = $model->new; }; if ($@) { return $self->_error("Error making new object from $model: $@"); } unless ( UNIVERSAL::isa( $new_model, 'Jifty::DBI::Record' ) ) { return $self->_error( "Didn't get a Jifty::DBI::Record from $model, got $new_model" ); } $model = $new_model; } my $table_obj = $self->_db_schema_table_from_model($model); $self->_db_schema->addtable($table_obj); return 1; } =head2 column_definition_sql TABLENAME COLUMNNAME Given a table name and a column name, returns the SQL fragment describing that column for the current database. =cut sub column_definition_sql { my $self = shift; my $table = shift; my $col = shift; my $table_obj = $self->_db_schema->table($table); return $table_obj->column( $col )->line( $self->handle->dbh ) } =head2 create_table_sql_statements Returns a list of SQL statements (as strings) to create tables for all of the models added to the SchemaGenerator. =cut sub create_table_sql_statements { my $self = shift; return map { $self->_db_schema->table($_)->sql_create_table($self->handle->dbh) } sort { $a cmp $b } $self->_db_schema->tables; } =head2 create_table_sql_text Returns a string containing a sequence of SQL statements to create tables for all of the models added to the SchemaGenerator. This is just a trivial wrapper around L. =cut sub create_table_sql_text { my $self = shift; return join "\n", map {"$_ ;\n"} $self->create_table_sql_statements; } =head2 PRIVATE _db_schema_table_from_model MODEL Takes an object of a subclass of Jifty::DBI::Record; returns a new C object corresponding to the model. =cut sub _db_schema_table_from_model { my $self = shift; my $model = shift; my $table_name = $model->table; my @columns = $model->columns; my @cols; my @indexes; for my $column (@columns) { # Skip "Virtual" columns - (foreign keys to collections) next if $column->virtual; # Skip computed columns next if $column->computed; # If schema_version is defined, make sure columns are for that version if ($model->can('schema_version') and defined $model->schema_version) { # Skip it if the app version is earlier than the column version next if defined $column->since and $model->schema_version < version->new($column->since); # Skip it if the app version is the same as or later than the # column version next if defined $column->till and $model->schema_version >= version->new($column->till); } # Otherwise, assume the latest version and eliminate till columns next if (!$model->can('schema_version') or !defined $model->schema_version) and defined $column->till; # Encode default values my $default = $column->default; # Scalar::Defer-powered defaults do not get a default in the database if (ref($default) ne '0' && defined $default) { $model->_handle($self->handle); $model->_apply_input_filters( column => $column, value_ref => \$default, ); $default = \"''" if defined $default and not length $default; $model->_handle(undef); } else { $default = ''; } push @cols, DBIx::DBSchema::Column->new( { name => $column->name, type => $column->type, null => $column->mandatory ? 0 : 1, default => $default, } ); if ($column->indexed) { push @indexes,[$column->name]; } } my $index_count = 1; my $table = DBIx::DBSchema::Table->new( { name => $table_name, primary_key => "id", columns => \@cols, (@indexes) ? (indices => [map {DBIx::DBSchema::Index->new(name => $table_name.$index_count++, columns => $_) } @indexes]) : () } ); return $table; } =head2 PRIVATE _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 =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to CRT NAMEE@rt.cpan.org>, or through the web interface at L. =head1 AUTHOR David Glasser C<< glasser@bestpractical.com >> Some pod by Eric Wilhelm =head1 LICENCE AND COPYRIGHT Copyright (c) 2005, Best Practical Solutions, LLC. 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. =cut Jifty-DBI-0.77/lib/Jifty/DBI/Handle.pm0000755000175000017500000010677311647720425016153 0ustar chmrrchmrrpackage Jifty::DBI::Handle; use strict; use Carp (); use DBI (); use Class::ReturnValue (); use Encode (); use base qw/Jifty::DBI::HasFilters/; use vars qw(%DBIHandle $PrevHandle $DEBUG $TRANSDEPTH); $TRANSDEPTH = 0; our $VERSION = '0.01'; if ( my $pattern = $ENV{JIFTY_DBQUERY_CALLER} ) { require Hook::LexWrap; Hook::LexWrap::wrap( 'Jifty::DBI::Handle::simple_query', pre => sub { return unless $_[1] =~ m/$pattern/; Carp::cluck($_[1] . ' ' . CORE::join( ',', @_[ 2 .. $#_ ] )); } ); } =head1 NAME Jifty::DBI::Handle - Perl extension which is a generic DBI handle =head1 SYNOPSIS use Jifty::DBI::Handle; my $handle = Jifty::DBI::Handle->new(); $handle->connect( driver => 'mysql', database => 'dbname', host => 'hostname', user => 'dbuser', password => 'dbpassword'); # now $handle isa Jifty::DBI::Handle::mysql =head1 DESCRIPTION This class provides a wrapper for DBI handles that can also perform a number of additional functions. =cut =head2 new Generic constructor =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless( $self, $class ); @{ $self->{'StatementLog'} } = (); return $self; } =head2 connect PARAMHASH Takes a paramhash and connects to your DBI datasource, with the keys C, C, C, C and C. If you created the handle with Jifty::DBI::Handle->new and there is a Jifty::DBI::Handle::(Driver) subclass for the driver you have chosen, the handle will be automatically "upgraded" into that subclass. If there is an error, an exception will be thrown. If a connection has already been established and is still active, C will be returned (which is not an error). Otherwise, if a new connection is made, a true value will be returned. =cut sub connect { my $self = shift; my %args = ( driver => undef, database => undef, host => undef, sid => undef, port => undef, user => undef, password => undef, requiressl => undef, extra => {}, @_ ); if ( $args{'driver'} && !$self->isa( 'Jifty::DBI::Handle::' . $args{'driver'} ) ) { if ( $self->_upgrade_handle( $args{'driver'} ) ) { return ( $self->connect(%args) ); } } my $dsn = $self->dsn || ''; # Setting this actually breaks old RT versions in subtle ways. So we need to explicitly call it $self->build_dsn(%args); # Only connect if we're not connected to this source already if ( ( !$self->dbh ) || ( !$self->dbh->ping ) || ( $self->dsn ne $dsn ) ) { my $handle = DBI->connect( $self->dsn, $args{'user'}, $args{'password'}, $args{'extra'} ) || Carp::croak "Connection failed: $DBI::errstr\n"; #databases do case conversion on the name of columns returned. #actually, some databases just ignore case. this smashes it to something consistent $handle->{FetchHashKeyName} = 'NAME_lc'; #Set the handle $self->dbh($handle); return (1); } return (undef); } =head2 _upgrade_handle DRIVER This private internal method turns a plain Jifty::DBI::Handle into one of the standard driver-specific subclasses. =cut sub _upgrade_handle { my $self = shift; my $driver = shift; my $class = 'Jifty::DBI::Handle::' . $driver; local $@; eval "require $class"; return if $@; bless $self, $class; return 1; } =head2 build_dsn PARAMHASH Builds a dsn suitable for handing to DBI->connect. Mandatory arguments: =over =item driver =item database =back Optional arguments: =over =item host =item port =item sid =item requiressl =item and anything else your DBD lets you pass in =back =cut sub build_dsn { my $self = shift; my %args = ( driver => undef, database => undef, host => undef, port => undef, sid => undef, requiressl => undef, @_ ); my $driver = delete $args{'driver'}; $args{'dbname'} ||= delete $args{'database'}; delete $args{'user'}; delete $args{'password'}; delete $args{'extra'}; $self->{'dsn'} = "dbi:$driver:" . CORE::join( ';', map { $_ . "=" . $args{$_} } grep { defined $args{$_} } keys %args ); } =head2 dsn Returns the dsn for this database connection. =cut sub dsn { my $self = shift; return ( $self->{'dsn'} ); } =head2 raise_error [MODE] Turns on the Database Handle's RaiseError attribute. =cut sub raise_error { my $self = shift; $self->dbh->{RaiseError} = shift if (@_); return $self->dbh->{RaiseError}; } =head2 print_error [MODE] Turns on the Database Handle's PrintError attribute. =cut sub print_error { my $self = shift; $self->dbh->{PrintError} = shift if (@_); return $self->dbh->{PrintError}; } =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 log_sql_statements BOOL Takes a boolean argument. If the boolean is true, it will log all SQL statements, as well as their invocation times and execution times. Returns whether we're currently logging or not as a boolean =cut sub log_sql_statements { my $self = shift; if (@_) { require Time::HiRes; $self->{'_dologsql'} = shift; } return ( $self->{'_dologsql'} ); } =head2 log_sql_hook NAME [, CODE] Used in instrumenting the SQL logging. You can use this to, for example, get a stack trace for each query (so you can find out where the query is being made). The name is required so that multiple hooks can be installed, and inspected, by name. The coderef is run in scalar context and (currently) receives no arguments. If you don't pass CODE in, then the coderef currently assigned under NAME is returned. =cut sub log_sql_hook { my $self = shift; my $name = shift; if (@_) { $self->{'_logsqlhooks'}{$name} = shift; } return ( $self->{'_logsqlhooks'}{$name} ); } =head2 _log_sql_statement STATEMENT DURATION BINDINGS add an SQL statement to our query log =cut sub _log_sql_statement { my $self = shift; my $statement = shift; my $duration = shift; my @bind = @_; my %results; my @log = (Time::HiRes::time(), $statement, [@bind], $duration, \%results); while (my ($name, $code) = each %{ $self->{'_logsqlhooks'} || {} }) { $results{$name} = $code->(@log); } push @{ $self->{'StatementLog'} }, \@log; } =head2 clear_sql_statement_log Clears out the SQL statement log. =cut sub clear_sql_statement_log { my $self = shift; @{ $self->{'StatementLog'} } = (); } =head2 sql_statement_log Returns the current SQL statement log as an array of arrays. Each entry is a list of: (Time, Statement, [Bindings], Duration, {HookResults}) Bindings is an arrayref of the values of any placeholders. HookResults is a hashref keyed by hook name. =cut sub sql_statement_log { my $self = shift; return ( @{ $self->{'StatementLog'} } ); } =head2 auto_commit [MODE] Turns on the Database Handle's Autocommit attribute. =cut sub auto_commit { my $self = shift; my $mode = 1; $mode = shift if (@_); $self->dbh->{AutoCommit} = $mode; } =head2 disconnect disconnect from your DBI datasource =cut sub disconnect { my $self = shift; if ( $self->dbh ) { return ( $self->dbh->disconnect() ); } else { return; } } =head2 dbh [HANDLE] Return the current DBI handle. If we're handed a parameter, make the database handle that. =cut sub dbh { my $self = shift; #If we are setting the database handle, set it. $DBIHandle{$self} = $PrevHandle = shift if (@_); return ( $DBIHandle{$self} ||= $PrevHandle ); } =head2 delete $table_NAME @KEY_VALUE_PAIRS Takes a table name and a set of key-value pairs in an array. splits the key value pairs, constructs an DELETE statement and performs the delete. Returns the row_id of this row. =cut sub delete { my ( $self, $table, @pairs ) = @_; my @bind = (); my $where = 'WHERE '; while ( my $key = shift @pairs ) { $where .= $key . "=?" . " AND "; push( @bind, shift(@pairs) ); } $where =~ s/AND $//; my $query_string = "DELETE FROM " . $table . ' ' . $where; $self->simple_query( $query_string, @bind ); } =head2 insert $table_NAME @KEY_VALUE_PAIRS Takes a table name and a set of key-value pairs in an array. splits the key value pairs, constructs an INSERT statement and performs the insert. Returns the row_id of this row. =cut sub insert { my ( $self, $table, @pairs ) = @_; my ( @cols, @vals, @bind ); #my %seen; #only the *first* value is used - allows drivers to specify default while ( my $key = shift @pairs ) { my $value = shift @pairs; # next if $seen{$key}++; push @cols, $key; push @vals, '?'; push @bind, $value; } my $query_string = "INSERT INTO $table (" . CORE::join( ", ", @cols ) . ") VALUES " . "(" . CORE::join( ", ", @vals ) . ")"; my $sth = $self->simple_query( $query_string, @bind ); return ($sth); } =head2 update_record_value Takes a hash with columns: C
, C, C, C, and C. The first two should be obvious; C is where you set the new value you want the column to have. The C column should be the lvalue of Jifty::DBI::Record::PrimaryKeys(). Finally , C is set when the Value is a SQL function. For example, you might have C<< value => 'PASSWORD(string)' >>, by setting C to true, that string will be inserted into the query directly rather then as a binding. =cut sub update_record_value { my $self = shift; my %args = ( table => undef, column => undef, is_sql_function => undef, primary_keys => undef, @_ ); return 1 unless grep {defined} values %{ $args{primary_keys} }; my @bind = (); my $query = 'UPDATE ' . $args{'table'} . ' '; $query .= 'SET ' . $args{'column'} . '='; ## Look and see if the column is being updated via a SQL function. if ( $args{'is_sql_function'} ) { $query .= $args{'value'} . ' '; } else { $query .= '? '; push( @bind, $args{'value'} ); } ## Constructs the where clause. my $where = 'WHERE '; foreach my $key ( keys %{ $args{'primary_keys'} } ) { $where .= $key . "=?" . " AND "; push( @bind, $args{'primary_keys'}{$key} ); } $where =~ s/AND\s$//; my $query_str = $query . $where; return ( $self->simple_query( $query_str, @bind ) ); } =head2 update_table_value table COLUMN NEW_value RECORD_ID IS_SQL Update column COLUMN of table table where the record id = RECORD_ID. If IS_SQL is set, don't quote the NEW_VALUE. =cut sub update_table_value { my $self = shift; ## This is just a wrapper to update_record_value(). my %args = (); $args{'table'} = shift; $args{'column'} = shift; $args{'value'} = shift; $args{'primary_keys'} = shift; $args{'is_sql_function'} = shift; return $self->update_record_value(%args); } =head2 simple_query QUERY_STRING, [ BIND_VALUE, ... ] Execute the SQL string specified in QUERY_STRING =cut our $retry_simple_query = 1; sub simple_query { my $self = shift; my $query_string = shift; my @bind_values; @bind_values = (@_) if (@_); my $sth = $self->dbh->prepare($query_string); unless ($sth) { my $message = "$self couldn't prepare the query '$query_string': " . $self->dbh->errstr; if ($DEBUG) { die "$message\n"; } else { warn "$message\n"; my $ret = Class::ReturnValue->new(); $ret->as_error( errno => '-1', message => $message, do_backtrace => undef ); return ( $ret->return_value ); } } # Check @bind_values for HASH refs for ( my $bind_idx = 0; $bind_idx < scalar @bind_values; $bind_idx++ ) { if ( ref( $bind_values[$bind_idx] ) eq "HASH" ) { my $bhash = $bind_values[$bind_idx]; $bind_values[$bind_idx] = $bhash->{'value'}; delete $bhash->{'value'}; $sth->bind_param( $bind_idx + 1, undef, $bhash ); } # Some databases, such as Oracle fail to cope if it's a perl utf8 # string. they desperately want bytes. Encode::_utf8_off( $bind_values[$bind_idx] ); } my $basetime; if ( $self->log_sql_statements ) { $basetime = Time::HiRes::time(); } my $executed; local $@; { no warnings 'uninitialized'; # undef in bind_values makes DBI sad eval { $executed = $sth->execute(@bind_values) }; # try to ping and reconnect, if the DB connection failed if (($@ or not $executed) and !$self->dbh->ping) { $self->dbh(undef); # don't try pinging again, just connect $self->connect; # Need to call ourselves, to create a new sth from the new dbh if ($retry_simple_query) { local $retry_simple_query = 0; return $self->simple_query($query_string, @_); } } } if ( $self->log_sql_statements ) { $self->_log_sql_statement( $query_string, Time::HiRes::time() - $basetime, @bind_values ); } if ( $@ or !$executed ) { my $message = "$self couldn't execute the query '$query_string': " . ($self->dbh->errstr || $@); if ($DEBUG) { die "$message\n"; } else { # XXX: This warn doesn't show up because we mask logging in Jifty::Test::END. # and it usually fails because the test server is still running. warn "$message\n"; my $ret = Class::ReturnValue->new(); $ret->as_error( errno => '-1', message => $message, do_backtrace => undef ); return ( $ret->return_value ); } } return ($sth); } =head2 fetch_result QUERY, [ BIND_VALUE, ... ] Takes a SELECT query as a string, along with an array of BIND_VALUEs If the select succeeds, returns the first row as an array. Otherwise, returns a Class::ResturnValue object with the failure loaded up. =cut sub fetch_result { my $self = shift; my $query = shift; my @bind_values = @_; my $sth = $self->simple_query( $query, @bind_values ); if ($sth) { return ( $sth->fetchrow ); } else { return ($sth); } } =head2 blob_params COLUMN_NAME COLUMN_TYPE Returns a hash ref for the bind_param call to identify BLOB types used by the current database for a particular column type. =cut sub blob_params { my $self = shift; # Don't assign to key 'value' as it is defined later. return ( {} ); } =head2 database_version Returns the database's version. If argument C is true returns short variant, in other case returns whatever database handle/driver returns. By default returns short version, e.g. C<4.1.23> or C<8.0-rc4>. Returns empty string on error or if database couldn't return version. The base implementation uses a C and ordering in the same statement; it drops the C requirement. This, of course, means that you can get the same row twice, which you might not want. If that's the case, use this module as a mix-in, and it will provide you with an C method which ensures that a record will not appear twice in the same search. =head1 AUTHOR Simon Cozens. =head1 COPYRIGHT Copyright 2005 Best Practical Solutions, LLC This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Jifty-DBI-0.77/lib/Jifty/DBI/Collection/Union.pm0000644000175000017500000001151311502103765020113 0ustar chmrrchmrrpackage Jifty::DBI::Collection::Union; use strict; use warnings; # WARNING --- This is still development code. It is experimental. our $VERSION = '0'; # This could inherit from Jifty::DBI, but there are _a lot_ # of things in Jifty::DBI that we don't want, like Limit and # stuff. It probably makes sense to (eventually) split out # Jifty::DBI::Collection to contain all the iterator logic. # This could inherit from that. =head1 NAME Jifty::DBI::Collection::Union - Deal with multiple L result sets as one =head1 SYNOPSIS use Jifty::DBI::Collection::Union; my $U = new Jifty::DBI::Collection::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 L 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 L 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 COLLECTION Add L object I 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 Jifty::DBI::Collection::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 Jifty::DBI::Collection::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; return undef unless defined $self->{data}[ $self->{curp} ]; my $cur = $self->{data}[ $self->{curp} ]; # do the search to avoid the count query and then search $cur->_do_search if $cur->{'must_redo_search'}; if ( $cur->_items_counter == $cur->count ) { # move to the next element $self->{curp}++; return undef unless defined $self->{data}[ $self->{curp} ]; $cur = $self->{data}[ $self->{curp} ]; $self->{data}[ $self->{curp} ]->goto_first_item; } $self->{item}++; $cur->next; } =head2 last Returns the last item =cut sub last { die "Last doesn't work right now"; my $self = shift; $self->goto_item( ( $self->count ) - 1 ); return ( $self->next ); } =head2 count Returns the total number of elements in the union 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 goto_first_item Starts the recordset counter over from the first item. the next time you call L, you'll get the first item returned by the database, as if you'd just started iterating through the result set. =cut sub goto_first_item { my $self = shift; $self->goto_item(0); } =head2 goto_item Unlike L, Union only supports going to the first item in the collection. =cut sub goto_item { 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]->goto_item(0); return $item; } =head2 is_last Returns true if the current row is the last record in the set. =cut sub is_last { my $self = shift; $self->{item} == $self->count ? 1 : undef; } =head2 items_array_ref Return a reference to an array containing all objects found by this search. Will destroy any positional state. =cut sub items_array_ref { my $self = shift; return [] unless $self->count; $self->goto_first_item(); 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 L, L =cut 1; __END__ Jifty-DBI-0.77/lib/Jifty/DBI/Column.pm0000644000175000017500000001472611710330634016174 0ustar chmrrchmrruse warnings; use strict; package Jifty::DBI::Column; our $VERSION = '0.01'; use base qw/Class::Accessor::Fast Jifty::DBI::HasFilters/; use UNIVERSAL::require; use version; my @attrs = qw/ name type default readable writable max_length mandatory virtual computed distinct sort_order refers_to by alias_for_column aliased_as since till indexed _validator _checked_for_validate_sub record_class attributes case_sensitive private protected encode_on_select /; # these actually live in the attributes hash my @handy_attrs = qw/ container label hints render_as display_length documentation valid_values available_values autocompleted no_placeholder /; # compat: this should probably never exist and be deprecated our @ATTRS = (@attrs, @handy_attrs); __PACKAGE__->mk_accessors(@attrs); for my $attr (@handy_attrs) { no strict 'refs'; *$attr = sub { my $self = shift; $self->attributes({}) unless $self->attributes; return $self->attributes->{$attr} unless @_; $self->attributes->{$attr} = (@_ == 1 ? $_[0] : [@_]); } } =head1 NAME Jifty::DBI::Column - Encapsulates a single column in a Jifty::DBI::Record table =head1 DESCRIPTION This class encapsulates a single column in a Jifty::DBI::Record table description. It replaces the _accessible method in L. It has the following accessors: C. =cut =head2 new =cut sub new { my ($class, $args) = @_; my $self = $class->SUPER::new({}); # run through accessors, push unknown keys into the attributes hash # XXX: we might want to construct the proper hash (lifting things # not in @attrs into attributes and just pass the whole hash $self->attributes({}); for (keys %$args) { if ($self->can($_)) { $self->$_($args->{$_}); } else { $self->attributes->{$_} = $args->{$_}; } } return $self; } =head2 is_numeric Returns true if the column is of some numeric type, otherwise returns false. =cut sub is_numeric { my $self = shift; if ( $self->type =~ /INT|NUMERIC|DECIMAL|REAL|DOUBLE|FLOAT/i ) { return 1; } return 0; } =head2 is_string Returns true if this column is a text field =cut sub is_string { my $self = shift; if ( $self->type =~ /CHAR|TEXT/i ){ return 1; } return 0; } =head2 is_boolean Returns true if this column is a boolean =cut sub is_boolean { my $self = shift; return 1 if grep { $_->isa('Jifty::DBI::Filter::Boolean') } $self->output_filters; return 1 if $self->type =~ /BOOL/i; return 0; } =head2 serialize_metadata Returns a hash describing this column object with enough detail to fully describe it in the database. Intentionally skips C, all column attributes starting with C<_>, and all column attributes which are undefined. The "known" attributes in the C hash are flattened and returned as well. The list of known attributes are: =over =item container =item label hints render_as =item display_length =item valid_values =item available_values =item autocompleted =item documentation =item no_placeholder Setting this to a true value causes L to not use a placeholder when loading the column. This can allow the database to come up with better query plans in some cases. =back =cut sub serialize_metadata { my $self = shift; return {map { $_ => $self->$_() } grep { $_ ne 'attributes' && $_ ne 'record_class' && $_ !~ /^_/ && defined $self->$_} @ATTRS}; } =head2 serialize_metadata2 Returns a hash describing this column object with enough detail to fully describe it in the database. Intentionally skips C, all column attributes starting with C<_>, and all column attributes which are undefined. =cut sub serialize_metadata2 { my $self = shift; return {map { $_ => $self->$_() } grep { $_ ne 'record_class' && $_ !~ /^_/ && defined $self->$_} @attrs}; } =head2 validator Gets/sets the validator coderef for the column. =cut sub validator { my $self = shift; if ( @_ ) { $self->_validator( shift ); } elsif ( not $self->_checked_for_validate_sub and not $self->_validator ) { my $name = ( $self->aliased_as ? $self->aliased_as : $self->name ); my $can = $self->record_class->can( "validate_" . $name ); $self->_validator( $can ) if $can; $self->_checked_for_validate_sub( 1 ); } return $self->_validator; } # Aliases for compatibility with searchbuilder code *read = \&readable; *write = \&writable; =head2 read DEPRECATED. Use C<< $column->readable >> instead. =head2 write DEPRECATED. Use C<< $column->writable >> instead. =head2 length DEPRECATED. Use C<< $column->max_length >> instead. =head2 until DEPRECATED. Use C<< $column->till >> instead. =cut sub length { Carp::croak('$column->length is no longer supported; use $column->max_length instead') } sub until { Carp::croak('$column->until is no longer supported; use $column->till instead') } =head2 active Returns the a true value if the column method exists for the current application version. The current application version is determined by checking the L of the column's L. This method returns a false value if the column is not yet been added or has been dropped. This method returns a false value under these circumstances: =over =item * Both the C trait and C method are defined and C is less than the version set on C. =item * Both the C trait and C method are defined and C is greater than or equal to the version set on C. =back Otherwise, this method returns true. =cut sub active { my $self = shift; return 1 unless $self->record_class->can('schema_version'); return 1 unless defined $self->record_class->schema_version; my $version = version->new($self->record_class->schema_version); # The application hasn't yet started using this column return 0 if defined $self->since and $version < version->new($self->since); # The application stopped using this column return 0 if defined $self->till and $version >= version->new($self->till); # The application currently uses this column return 1; } 1; Jifty-DBI-0.77/lib/Jifty/DBI/Schema.pm0000644000175000017500000005571711576426730016161 0ustar chmrrchmrruse warnings; use strict; package Jifty::DBI::Schema; =head1 NAME Jifty::DBI::Schema - Use a simple syntax to describe a Jifty table. =head1 SYNOPSIS package MyApp::Model::Page; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { # ... your columns here ... }; =cut =head1 DESCRIPTION Each Jifty Application::Model::Class module describes a record class for a Jifty application. Each C statement sets out the name and attributes used to describe the column in a backend database, in user interfaces, and other contexts. For example: column content => type is 'text', label is 'Content', render as 'textarea'; defines a column called C that is of type C. It will be rendered with the label C (note the capital) and as a C