[Jifty-commit] r7333 - in Jifty-DBI/branches/tisql: . inc/Module inc/Module/Install lib/Jifty lib/Jifty/DBI t
Jifty commits
jifty-commit at lists.jifty.org
Sat Jul 18 08:33:38 EDT 2009
Author: ruz
Date: Sat Jul 18 08:33:37 2009
New Revision: 7333
Added:
Jifty-DBI/branches/tisql/t/03rename_column.t
Jifty-DBI/branches/tisql/t/03rename_table.t
Jifty-DBI/branches/tisql/t/06filter_salthash.t
Modified:
Jifty-DBI/branches/tisql/ (props changed)
Jifty-DBI/branches/tisql/.gitignore
Jifty-DBI/branches/tisql/Changes
Jifty-DBI/branches/tisql/MANIFEST
Jifty-DBI/branches/tisql/META.yml
Jifty-DBI/branches/tisql/SIGNATURE
Jifty-DBI/branches/tisql/inc/Module/Install.pm
Jifty-DBI/branches/tisql/inc/Module/Install/AutoInstall.pm
Jifty-DBI/branches/tisql/inc/Module/Install/Base.pm
Jifty-DBI/branches/tisql/inc/Module/Install/Can.pm
Jifty-DBI/branches/tisql/inc/Module/Install/Fetch.pm
Jifty-DBI/branches/tisql/inc/Module/Install/Include.pm
Jifty-DBI/branches/tisql/inc/Module/Install/Makefile.pm
Jifty-DBI/branches/tisql/inc/Module/Install/Metadata.pm
Jifty-DBI/branches/tisql/inc/Module/Install/Win32.pm
Jifty-DBI/branches/tisql/inc/Module/Install/WriteAll.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI/Collection.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI/Column.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle/SQLite.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle/mysql.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI/HasFilters.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI/Record.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI/Schema.pm
Jifty-DBI/branches/tisql/lib/Jifty/DBI/SchemaGenerator.pm
Jifty-DBI/branches/tisql/t/02searches_joins.t
Jifty-DBI/branches/tisql/t/utils.pl (contents, props changed)
Log:
r7220 at Macintosh: ruz | 2009-06-07 23:17:13 +0300
* trunk -> tisql
r6725 at Macintosh (orig r6700): alexmv | 2009-03-25 22:31:52 +0200
r43616 at kohr-ah: chmrr | 2009-03-25 15:30:45 -0400
0.53 releng
r6727 at Macintosh (orig r6702): alexmv | 2009-03-25 22:38:12 +0200
r43621 at kohr-ah: chmrr | 2009-03-25 15:38:07 -0400
Version bump after 0.53 release
r6735 at Macintosh (orig r6710): sterling | 2009-03-30 05:38:49 +0300
Added a unit test for the SaltHash filter
r6736 at Macintosh (orig r6711): sterling | 2009-03-30 05:41:22 +0300
SaltHash test does not need an is_deeply() here
r6799 at Macintosh (orig r6774): ruz | 2009-04-15 03:46:43 +0300
* move log method
r6800 at Macintosh (orig r6775): ruz | 2009-04-15 20:57:26 +0300
* add schema manipulation tables: rename_column and rename_table
r6801 at Macintosh (orig r6776): ruz | 2009-04-15 20:58:24 +0300
* make similar API in rename_column/rename_table
r6802 at Macintosh (orig r6777): ruz | 2009-04-15 21:00:55 +0300
* add special implementations of rename_column in SQLite and mysql
* weak and suckish in some corners, but work for 80% of cases
r6803 at Macintosh (orig r6778): ruz | 2009-04-15 21:03:32 +0300
* add tests for rename_column
r6804 at Macintosh (orig r6779): ruz | 2009-04-15 21:39:29 +0300
* ALTER TABLE for rename_table shows better consistency over DBs
r6806 at Macintosh (orig r6781): ruz | 2009-04-15 21:43:53 +0300
* test rename_table
r6807 at Macintosh (orig r6782): ruz | 2009-04-15 21:49:32 +0300
* unconditionaly drop tables for testing
r6808 at Macintosh (orig r6783): ruz | 2009-04-16 01:06:13 +0300
* version bump, 0.55
r6809 at Macintosh (orig r6784): ruz | 2009-04-16 01:07:50 +0300
* oops, we bumped 0.55 actualy
r6823 at Macintosh (orig r6798): sartak | 2009-04-18 04:00:41 +0300
Add .gitignore
r6937 at Macintosh (orig r6912): sunnavy | 2009-04-29 08:00:50 +0300
make pod-coverage happy
r6940 at Macintosh (orig r6915): sartak | 2009-04-30 00:31:03 +0300
Improve SQL error message and avoid its duplication
r6941 at Macintosh (orig r6916): sartak | 2009-04-30 00:31:36 +0300
Typo fix
r6942 at Macintosh (orig r6917): sartak | 2009-04-30 03:09:56 +0300
If a column's default is a record, call its id method
r6963 at Macintosh (orig r6938): sartak | 2009-05-05 00:02:25 +0300
Add a display_length attribute on columns
r6975 at Macintosh (orig r6950): sartak | 2009-05-07 03:54:10 +0300
Pull the input_ and output_filters out of the instance hash
r6978 at Macintosh (orig r6953): alexmv | 2009-05-08 02:43:51 +0300
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.
r6996 at Macintosh (orig r6971): ruz | 2009-05-11 21:21:10 +0300
* bump verion, 0.56
r6999 at Macintosh (orig r6974): alexmv | 2009-05-11 22:29:58 +0300
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.
r7004 at Macintosh (orig r6979): sartak | 2009-05-12 00:26:59 +0300
eval in DESTROY can cause $@ issues, so localize $@
r7006 at Macintosh (orig r6981): ruz | 2009-05-12 01:15:31 +0300
* add drop_table_if_exists in t/utils.t
r7007 at Macintosh (orig r6982): ruz | 2009-05-12 01:16:11 +0300
* use drop_table_if_exists in tests
r7008 at Macintosh (orig r6983): ruz | 2009-05-12 01:17:14 +0300
* update pod
r7009 at Macintosh (orig r6984): ruz | 2009-05-12 01:27:47 +0300
* oops, hardcoded table name in the query
r7072 at Macintosh (orig r7047): sartak | 2009-05-18 22:25:48 +0300
Do not use Scalar::Defer defaults for columns' defaults in the db
r7077 at Macintosh (orig r7052): sartak | 2009-05-19 16:05:33 +0300
0.57 changes
r7078 at Macintosh (orig r7053): sartak | 2009-05-19 16:18:08 +0300
Don't explicitly disconnect the handle, DESTROY handles it better
r7079 at Macintosh (orig r7054): sartak | 2009-05-19 16:18:11 +0300
Silence some intentional test warnings by testing them
r7080 at Macintosh (orig r7055): sartak | 2009-05-19 16:22:11 +0300
Destroy the handle explicitly to avoid more warnings
r7081 at Macintosh (orig r7056): sartak | 2009-05-19 16:22:14 +0300
Test more intentional warnings
r7082 at Macintosh (orig r7057): sartak | 2009-05-19 16:26:27 +0300
Last change :)
r7083 at Macintosh (orig r7058): sartak | 2009-05-19 16:28:16 +0300
Bump to 0.57
r7084 at Macintosh (orig r7059): sartak | 2009-05-19 16:31:17 +0300
Add more to MANIFEST and MANIFEST.SKIP
r7085 at Macintosh (orig r7060): sartak | 2009-05-19 16:31:30 +0300
Regenerate SIGNATURE
r7086 at Macintosh (orig r7061): sartak | 2009-05-19 16:33:03 +0300
Post-release version bump
r7111 at Macintosh (orig r7086): sartak | 2009-05-20 22:47:08 +0300
Remove unused _limit_clause, limiting is a method on the handle
r7149 at Macintosh (orig r7124): sartak | 2009-06-01 23:14:15 +0300
Turn on strict and warnings for Jifty::DBI::Schema too
r7203 at Macintosh (orig r7178): sartak | 2009-06-05 02:04:14 +0300
Move supported_drivers and available_drivers into methods on the Handle class
r7204 at Macintosh (orig r7179): sartak | 2009-06-05 02:06:14 +0300
Handle->is_available_driver('Pg')
Modified: Jifty-DBI/branches/tisql/.gitignore
==============================================================================
--- Jifty-DBI/branches/tisql/.gitignore (original)
+++ Jifty-DBI/branches/tisql/.gitignore Sat Jul 18 08:33:37 2009
@@ -1,6 +1,10 @@
+MANIFEST
MANIFEST.bak
+META.yml
Makefile
Makefile.old
SIGNATURE
blib/
+inc/
pm_to_blib
+
Modified: Jifty-DBI/branches/tisql/Changes
==============================================================================
--- Jifty-DBI/branches/tisql/Changes (original)
+++ Jifty-DBI/branches/tisql/Changes Sat Jul 18 08:33:37 2009
@@ -1,5 +1,143 @@
Revision history for Perl extension Jifty::DBI.
+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
@@ -91,8 +229,9 @@
* 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
+
+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.
@@ -117,8 +256,9 @@
* manifest skip pm_to_blib, add new test file to manifest
* Update Changes
-0.47 Fri Nov 16 15:23:28 EST 2007
+
+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
@@ -161,13 +301,15 @@
* Whoops, turned off the wrong warning
* POD coverage
-0.46 Wed Nov 7 12:24:08 EST 2007
+
+0.46 Wed Nov 7 12:24:08 EST 2007
- POD Coverage nit
- Fix for a stray tempfiles bug reported by ANDK
-0.45
+
+0.45
Add a warning for mandatory+till until we fix it
Fix the mandatory/inactive tests
Modified: Jifty-DBI/branches/tisql/MANIFEST
==============================================================================
--- Jifty-DBI/branches/tisql/MANIFEST (original)
+++ Jifty-DBI/branches/tisql/MANIFEST Sat Jul 18 08:33:37 2009
@@ -1,3 +1,4 @@
+.gitignore
Changes
debian/changelog
debian/compat
@@ -73,12 +74,15 @@
t/02records_object.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_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
Modified: Jifty-DBI/branches/tisql/META.yml
==============================================================================
--- Jifty-DBI/branches/tisql/META.yml (original)
+++ Jifty-DBI/branches/tisql/META.yml Sat Jul 18 08:33:37 2009
@@ -1,22 +1,22 @@
----
+---
author: ~
-build_requires:
- DBD::SQLite: 0
+build_requires:
+ DBD::SQLite: 1.14
Test::More: 0.52
Test::Warn: 0.1
distribution_type: module
-generated_by: Module::Install version 0.68
+generated_by: 'Module::Install version 0.79'
license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.3.html
- version: 1.3
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
name: Jifty-DBI
-no_index:
- directory:
+no_index:
+ directory:
- ex
- inc
- t
-requires:
+requires:
Cache::Simple::TimedExpiry: 0.21
Class::Accessor::Fast: 0
Class::Data::Inheritable: 0
@@ -25,7 +25,7 @@
Clone: 0
DBI: 0
DBIx::DBSchema: 0.34
- Data::Page: 0
+ Data::Page: 2.0
DateTime: 0.34
DateTime::Format::ISO8601: 0
DateTime::Format::Strptime: 0
@@ -39,4 +39,6 @@
YAML::Syck: 0
perl: 5.8.3
version: 0
-version: 0.49
+resources:
+ license: http://dev.perl.org/licenses/
+version: 0.53
Modified: Jifty-DBI/branches/tisql/SIGNATURE
==============================================================================
--- Jifty-DBI/branches/tisql/SIGNATURE (original)
+++ Jifty-DBI/branches/tisql/SIGNATURE Sat Jul 18 08:33:37 2009
@@ -14,10 +14,11 @@
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 a1e90ada944f4f566a22eb278ddf514153053c81 Changes
-SHA1 d44e458dea3e9f8afe04fead6857c9360d232af8 MANIFEST
-SHA1 819374d4317fb068696f1f6e1bc1f1e3868d9fa6 META.yml
-SHA1 13801def329494f8f119a2659f71b710f9d13aa3 Makefile.PL
+SHA1 f29ac6543498d1b0e81f387b7284a039f83e7d29 .gitignore
+SHA1 85746120ae35bfdb3811297cfc3331a0d1c56343 Changes
+SHA1 006b044e48cc925d04f620f317a907d459b2d128 MANIFEST
+SHA1 d3897bc376b40669acb9171adfd51f321d184fd8 META.yml
+SHA1 48bd6ca8a37ec79b7cae91028d7e9489ad33a03b Makefile.PL
SHA1 ae8407c841f230c353f683bd5c257815aed9b9f0 README
SHA1 82d6ac3f6def48558d09f8b6e3b53ed4194d8c81 ROADMAP
SHA1 9d304f35438f847863969f6a069598379f5a9db2 debian/README
@@ -30,25 +31,25 @@
SHA1 7cea1a5289f79c2a87837924a83feb583f6e8890 ex/Example/Model/Employee.pm
SHA1 a9d62e4f5b43b2f78066172a4771238ee7df6339 ex/create_tables.pl
SHA1 603bb9de29fb8cba7f13409c546750972eff645d inc/Module/AutoInstall.pm
-SHA1 7e2cfa1b9efe0d502ee57717649c90ba4bd28ba9 inc/Module/Install.pm
-SHA1 182a0df45b65151afdc2be0b7246a2d02d0f0567 inc/Module/Install/AutoInstall.pm
-SHA1 6e1392d80a0f239eecd5664f7f21f922cedb9329 inc/Module/Install/Base.pm
-SHA1 f69417fe831d9cc22a78f00a617afadceade4d81 inc/Module/Install/Can.pm
-SHA1 c61d02895330310048bf388881b5e2e064031561 inc/Module/Install/Fetch.pm
-SHA1 4933b00c3a646da8d223c6957f94552bbd62f8c6 inc/Module/Install/Include.pm
-SHA1 54fcbed19232ec959bb17cfb4410599afc7f0779 inc/Module/Install/Makefile.pm
-SHA1 7d3be9b158e37b2b2c22084740099955623b1d56 inc/Module/Install/Metadata.pm
-SHA1 0a8b66180229ba2f9deaea1fedd0aacf7a7ace6b inc/Module/Install/Win32.pm
-SHA1 d3352eb33fe43a5f3ead513f645224fe34d73bc9 inc/Module/Install/WriteAll.pm
-SHA1 d995b8919444a5245c506495b96aab104f7b8166 lib/Jifty/DBI.pm
-SHA1 09eb4ebb041498d7e8077eed0f013fefb2cc1606 lib/Jifty/DBI/Collection.pm
+SHA1 ae018c4565c1277089ca8f1b28f888d95430cb7f inc/Module/Install.pm
+SHA1 0a6f29536bedea3bb94744a7d43ffe39da7e4819 inc/Module/Install/AutoInstall.pm
+SHA1 4552acdfca8b78f8015d8449e1325616259095f5 inc/Module/Install/Base.pm
+SHA1 7fb663fff161fb45882b52edd62857bf15359658 inc/Module/Install/Can.pm
+SHA1 8b1d3db746faa6faf2d967a48d3812ec1f44b4c6 inc/Module/Install/Fetch.pm
+SHA1 d7ce736cdd05d5156d379ef39cca93beeeeba828 inc/Module/Install/Include.pm
+SHA1 9f6beaa2f4749ceb5dd0c9b0c647d0f3289c7b46 inc/Module/Install/Makefile.pm
+SHA1 7ad1da4fff7a1e7a634c9d734111c8292be08884 inc/Module/Install/Metadata.pm
+SHA1 e9aa83f3e8b16ccfce544a90a57b63b70a497759 inc/Module/Install/Win32.pm
+SHA1 ade2ac0b0246d4d8e28fa46942e53f6925abda46 inc/Module/Install/WriteAll.pm
+SHA1 249e7173876dca5ea914281036c853f7c9226991 lib/Jifty/DBI.pm
+SHA1 f181211220602d2883fd8d006fdb3c79ca417b05 lib/Jifty/DBI/Collection.pm
SHA1 639ef9c81f03fb084b312a5f9a6f6a3ff63b36b7 lib/Jifty/DBI/Collection/Union.pm
SHA1 bcba77fd2bacf0475aea1de97f57365c8de92ca6 lib/Jifty/DBI/Collection/Unique.pm
-SHA1 0e6346b30448482f0265221325de4b209dcc13fb lib/Jifty/DBI/Column.pm
-SHA1 cdce125423fb907a12e888a60522cb5d03cda5c0 lib/Jifty/DBI/Filter.pm
+SHA1 6d59ec1286f3ed887494753d01ed1f4760fd0a9b lib/Jifty/DBI/Column.pm
+SHA1 c21a985a5b799e50f2624e0fa6daee0895313825 lib/Jifty/DBI/Filter.pm
SHA1 e030c3ef5c723ba6dce2e3fc23afecf2a6dfe260 lib/Jifty/DBI/Filter/Boolean.pm
-SHA1 87192bf64a224cbea78770f4209ecae9981f3f5c lib/Jifty/DBI/Filter/Date.pm
-SHA1 70ffc9da2f13fc1aabd652169ba5a08b292ba678 lib/Jifty/DBI/Filter/DateTime.pm
+SHA1 d0addaa43cfa8950cb33d42a364a3c3c56a2dd59 lib/Jifty/DBI/Filter/Date.pm
+SHA1 92528e882daf77aea6aff118c223f578f702f87a 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
@@ -58,37 +59,41 @@
SHA1 67ffe7188a1f529d7594f4fa3803bcbe15ba6485 lib/Jifty/DBI/Filter/YAML.pm
SHA1 9a6fd17e677321904436fefec4d434e17a4685b1 lib/Jifty/DBI/Filter/base64.pm
SHA1 deb33fa7b35f3542aac3e2d7fb4b5d3070dc3917 lib/Jifty/DBI/Filter/utf8.pm
-SHA1 fdc47b3260594e60500125246b6f8a8f92ea142a lib/Jifty/DBI/Handle.pm
+SHA1 ac3555c9ec6bdf462e24d043e34b977625ca6407 lib/Jifty/DBI/Handle.pm
SHA1 bcc7c456e1c4d0dddd5564f03c8bb03a6c7e261f lib/Jifty/DBI/Handle/Informix.pm
SHA1 338116a45f8eb6bfca5e76e8d3be78fb61fffe81 lib/Jifty/DBI/Handle/ODBC.pm
SHA1 960fd0b63f3de11924c5d47a3c0c6d1db105ed5b lib/Jifty/DBI/Handle/Oracle.pm
-SHA1 88573513df75869a536443e4a34006477577df9f lib/Jifty/DBI/Handle/Pg.pm
-SHA1 860b373ddb0d0a1d001f20c721d9dffe003e2517 lib/Jifty/DBI/Handle/SQLite.pm
+SHA1 23eeff073884c8951e004be4308ca946a1d5e205 lib/Jifty/DBI/Handle/Pg.pm
+SHA1 1e850abb12a1d970eae373f452219c123be350e6 lib/Jifty/DBI/Handle/SQLite.pm
SHA1 bba2314c20fcc3ef71cc69090f1cd6bd515cd9b4 lib/Jifty/DBI/Handle/Sybase.pm
-SHA1 e6041a34c3044ed8b9691a5629ecf146fed95257 lib/Jifty/DBI/Handle/mysql.pm
+SHA1 cf80896a175702a157770f64ae469430678c3357 lib/Jifty/DBI/Handle/mysql.pm
SHA1 f2cc4fcce79c9a88a023d4e6bd96c2089eef1ced lib/Jifty/DBI/Handle/mysqlPP.pm
-SHA1 0e975f9ec5480ca09025c592c06d484058e637df lib/Jifty/DBI/HasFilters.pm
-SHA1 954c6673811421607d8780038934f39b7700fb84 lib/Jifty/DBI/Record.pm
-SHA1 1c8b4adcd312024a3408a52d3b2ef288c2084603 lib/Jifty/DBI/Record/Cachable.pm
-SHA1 526ea0d42808425435c21ffb0bc4b92c636a6176 lib/Jifty/DBI/Record/Memcached.pm
-SHA1 6a70dc2a6fd6a5d77502d391ac2630d91a681c1a lib/Jifty/DBI/Record/Plugin.pm
-SHA1 95c3151c475f1ffea7ce33ced9166d601c5ecdfe lib/Jifty/DBI/Schema.pm
-SHA1 36a88a3bec092873e86ca2f1cf7edbdb5b358a53 lib/Jifty/DBI/SchemaGenerator.pm
+SHA1 45d653e3a223599b50850010826bd835b80368d7 lib/Jifty/DBI/HasFilters.pm
+SHA1 fc176a04f20301b698a390a014eda349d139d94f lib/Jifty/DBI/Record.pm
+SHA1 3853ce268985b129f2175251fb369d9689837f39 lib/Jifty/DBI/Record/Cachable.pm
+SHA1 1aac77960c508d3b2e5188e15825ad5b04391d76 lib/Jifty/DBI/Record/Memcached.pm
+SHA1 53834b3315a509ba33a8647681f472d3ae7b0557 lib/Jifty/DBI/Record/Plugin.pm
+SHA1 501fe382b24b663c328fbb9c1cbf019c78e7bb53 lib/Jifty/DBI/Schema.pm
+SHA1 a4d1a953ea4a29fe169b1c4c043ffff15b24c077 lib/Jifty/DBI/SchemaGenerator.pm
SHA1 32834b7c4cf5a8d131382fccc8db341be8768291 t/00.load.t
SHA1 9aa7fed2b2409faa4c71d2a45db210721f47403e t/01-version_checks.t
SHA1 13c9fe3eeec0d000a7c86ea2474e30186cbc37e2 t/01basics.t
SHA1 018309dfc89440dc670cccf6138e3d4679465b47 t/01records.t
SHA1 7574130aa1dc5338b6efcd0f04eca3f6dc4b2696 t/01searches.t
SHA1 df97ee4e5bcb4ef0663dcc1a8db86dc66e8d9206 t/02-column_constraints.t
-SHA1 90a5b9c663002e3c43a00b7f9a04d6ec2787500e t/02records_cachable.t
+SHA1 1c2bd056c575bc74caf2e59bdda8d8eb2731a3e7 t/02records_cachable.t
SHA1 33642a61fd4b5a88436a82c6dd0fef359ba74a2b t/02records_object.t
-SHA1 369d71ca9ec0f00116ac6be24e017f592ac9cc45 t/02searches_joins.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 4d2b42f80c2adaab70aa236a720cf57fa4b65677 t/05raw_value.t
SHA1 f0371e275879019e2abe732bbb5626d0d05049a0 t/06filter.t
-SHA1 bfb0f7133ce399738b2afe6e9e716134289acaa6 t/06filter_boolean.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
@@ -96,7 +101,7 @@
SHA1 64c3722f5b34feafc87113257079721c174f3f96 t/10schema.t
SHA1 0f4655f0a4e558ac31df7b7fdf17c9b110f934da t/11schema_records.t
SHA1 22a083137927a8635b02931e40f80c60220ec3a7 t/12prefetch.t
-SHA1 063586c498fdc7fc90519f1d1a3e37838d637104 t/13collection.t
+SHA1 2389b47958bd6f92a561ca893d7bfab166ced127 t/13collection.t
SHA1 41b7fbaf031d103a4f2066f177cc3bee84ab0458 t/14handle-pg.t
SHA1 4f41229caa246bf6ebb369010deb0c1eb8809666 t/15types.t
SHA1 5958e59e29d29fbf3862b5d3471472cbd82d191e t/16inheritance.t
@@ -109,11 +114,11 @@
SHA1 59c44900b1cb957d262f96363ceff21b46e0d598 t/pod-coverage.t
SHA1 e9c6a5881fc60173fbc8d479c1afd2ce3b43bef1 t/pod.t
SHA1 62742c946808f35bcc8b2777e975c1ce068a0a71 t/testmodels.pl
-SHA1 2cf6ba23eb00dfed6f10533830da066c774c030c t/utils.pl
+SHA1 b11b0df92ffef5a617cf77b74c8b963be577e3c0 t/utils.pl
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.7 (Darwin)
-iD8DBQFH+t3rsxfQtHhyRPoRAlcOAJkBmvOV+Fc/7t5ULT/HPwXwlGgCzQCeJBy7
-6UTu17Js7YWoKbUQ6XpP8j8=
-=cQ9D
+iD8DBQFKEqZ7sxfQtHhyRPoRAojSAJsFA4i59HHzcODcLP1I8DldBgijBQCdGsQ1
+zTjK+DO/zkobfCE4js2KjII=
+=cRri
-----END PGP SIGNATURE-----
Modified: Jifty-DBI/branches/tisql/inc/Module/Install.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install.pm Sat Jul 18 08:33:37 2009
@@ -17,20 +17,30 @@
# 3. The ./inc/ version of Module::Install loads
# }
-use 5.004;
+BEGIN {
+ require 5.004;
+}
use strict 'vars';
use vars qw{$VERSION};
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 = '0.68';
+ # 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 = '0.79';
+
+ *inc::Module::Install::VERSION = *VERSION;
+ @inc::Module::Install::ISA = __PACKAGE__;
+
}
+
+
+
+
# 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.
@@ -38,26 +48,29 @@
# 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";
+unless ( $INC{$file} ) { die <<"END_DIE" }
+
Please invoke ${\__PACKAGE__} with:
- use inc::${\__PACKAGE__};
+ use inc::${\__PACKAGE__};
not:
- use ${\__PACKAGE__};
+ use ${\__PACKAGE__};
END_DIE
-}
+
+
+
+
# 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 and (stat($0))[9] > time ) {
- die << "END_DIE";
+if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
+
Your installer $0 has a modification time in the future.
This is known to create infinite loops in make.
@@ -65,115 +78,144 @@
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));
+
+
+
+
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
-*inc::Module::Install::VERSION = *VERSION;
- at inc::Module::Install::ISA = __PACKAGE__;
-
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;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unshift @_, ($self, $1);
- goto &{$self->can('call')} unless uc($1) eq $1;
- };
+ 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;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unless ( uc($1) eq $1 ) {
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')};
+ }
+ };
}
sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- unless ( -f $self->{file} ) {
- 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"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ unless ( -f $self->{file} ) {
+ 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"};
+ }
+
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+
+ return 1;
}
sub preload {
- my ($self) = @_;
-
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $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 ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
+ my $self = shift;
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $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 ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
}
sub new {
- my ($class, %args) = @_;
+ my ($class, %args) = @_;
- # 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";
+ # 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 );
+ bless( \%args, $class );
}
sub call {
@@ -184,98 +226,144 @@
}
sub load {
- my ($self, $method) = @_;
-
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- ) unless $self->{extensions};
+ my ($self, $method) = @_;
- foreach my $obj (@{$self->{extensions}}) {
- return $obj if $obj->can($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";
+ 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;
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
- $obj;
+ $obj;
}
sub load_extensions {
- my ($self, $path, $top) = @_;
+ my ($self, $path, $top) = @_;
- unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $INC{$file};
- push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
- }
+ unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
- $self->{extensions} ||= [];
+ $self->{extensions} ||= [];
}
sub find_extensions {
- my ($self, $path) = @_;
+ 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;
- 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) ) {
- open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
- my $in_pod = 0;
- while ( <PKGFILE> ) {
- $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;
- }
- }
- close PKGFILE;
- }
+ # 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;
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
- @found;
+ @found;
}
+
+
+
+
+#####################################################################
+# Utility Functions
+
sub _caller {
- my $depth = 0;
- my $call = caller($depth);
- while ( $call eq __PACKAGE__ ) {
- $depth++;
- $call = caller($depth);
- }
- return $call;
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+sub _read {
+ local *FH;
+ open FH, "< $_[0]" or die "open($_[0]): $!";
+ my $str = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $str;
+}
+
+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]): $!";
+}
+
+# _version is for processing module versions (eg, 1.03_05) not
+# Perl versions (eg, 5.8.1).
+
+sub _version ($) {
+ my $s = shift || 0;
+ $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;
+}
+
+# Cloned from Params::Util::_CLASS
+sub _CLASS ($) {
+ (
+ defined $_[0]
+ and
+ ! ref $_[0]
+ and
+ $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
+ ) ? $_[0] : undef;
}
1;
+
+# Copyright 2008 - 2009 Adam Kennedy.
Modified: Jifty-DBI/branches/tisql/inc/Module/Install/AutoInstall.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install/AutoInstall.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install/AutoInstall.pm Sat Jul 18 08:33:37 2009
@@ -6,7 +6,7 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.79';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
Modified: Jifty-DBI/branches/tisql/inc/Module/Install/Base.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install/Base.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install/Base.pm Sat Jul 18 08:33:37 2009
@@ -1,7 +1,7 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.68';
+$VERSION = '0.79';
# Suspend handler for "redefined" warnings
BEGIN {
@@ -45,6 +45,8 @@
$_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
}
+#line 101
+
sub is_admin {
$_[0]->admin->VERSION;
}
@@ -67,4 +69,4 @@
1;
-#line 138
+#line 146
Modified: Jifty-DBI/branches/tisql/inc/Module/Install/Can.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install/Can.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install/Can.pm Sat Jul 18 08:33:37 2009
@@ -11,7 +11,7 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.79';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -39,6 +39,7 @@
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 '';
my $abs = File::Spec->catfile($dir, $_[1]);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
@@ -79,4 +80,4 @@
__END__
-#line 157
+#line 158
Modified: Jifty-DBI/branches/tisql/inc/Module/Install/Fetch.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install/Fetch.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install/Fetch.pm Sat Jul 18 08:33:37 2009
@@ -6,20 +6,20 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.79';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
sub get_file {
my ($self, %args) = @_;
- my ($scheme, $host, $path, $file) =
+ 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) =
+ ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
Modified: Jifty-DBI/branches/tisql/inc/Module/Install/Include.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install/Include.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install/Include.pm Sat Jul 18 08:33:37 2009
@@ -6,7 +6,7 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.79';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
Modified: Jifty-DBI/branches/tisql/inc/Module/Install/Makefile.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install/Makefile.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install/Makefile.pm Sat Jul 18 08:33:37 2009
@@ -7,7 +7,7 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.79';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -36,9 +36,9 @@
sub makemaker_args {
my $self = shift;
- my $args = ($self->{makemaker_args} ||= {});
- %$args = ( %$args, @_ ) if @_;
- $args;
+ my $args = ( $self->{makemaker_args} ||= {} );
+ %$args = ( %$args, @_ );
+ return $args;
}
# For mm args that take multiple space-seperated args,
@@ -63,18 +63,18 @@
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
- %$clean = (
- %$clean,
- FILES => join(' ', grep length, $clean->{FILES}, @_),
+ %$clean = (
+ %$clean,
+ FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
- my $self = shift;
+ my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
- %$realclean = (
- %$realclean,
- FILES => join(' ', grep length, $realclean->{FILES}, @_),
+ %$realclean = (
+ %$realclean,
+ FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
@@ -104,8 +104,8 @@
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
- require File::Find;
%test_dir = ();
+ require File::Find;
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
@@ -114,10 +114,21 @@
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
+ # Make sure we have a new enough
+ require ExtUtils::MakeMaker;
+
+ # MakeMaker can complain about module versions that include
+ # an underscore, even though its own version may contain one!
+ # Hence the funny regexp to get rid of it. See RT #35800
+ # for details.
+
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+
+ # Generate the
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
- $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} = $self->module_name || $self->name;
+ $args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
@@ -142,9 +153,12 @@
map { @$_ }
map { @$_ }
grep $_,
- ($self->build_requires, $self->requires)
+ ($self->configure_requires, $self->build_requires, $self->requires)
);
+ # Remove any reference to perl, PREREQ_PM doesn't support it
+ delete $args->{PREREQ_PM}->{perl};
+
# merge both kinds of requires into prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
@@ -167,7 +181,9 @@
my $user_preop = delete $args{dist}->{PREOP};
if (my $preop = $self->admin->preop($user_preop)) {
- $args{dist} = $preop;
+ foreach my $key ( keys %$preop ) {
+ $args{dist}->{$key} = $preop->{$key};
+ }
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
@@ -180,7 +196,7 @@
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
- my $preamble = $self->preamble
+ my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
@@ -205,7 +221,7 @@
#$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;
+ $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;
@@ -234,4 +250,4 @@
__END__
-#line 363
+#line 379
Modified: Jifty-DBI/branches/tisql/inc/Module/Install/Metadata.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install/Metadata.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install/Metadata.pm Sat Jul 18 08:33:37 2009
@@ -6,63 +6,110 @@
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.79';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
my @scalar_keys = qw{
- name module_name abstract author version license
- distribution_type perl_version tests installdirs
+ name
+ module_name
+ abstract
+ author
+ version
+ distribution_type
+ tests
+ installdirs
};
my @tuple_keys = qw{
- build_requires requires recommends bundles
+ configure_requires
+ build_requires
+ requires
+ recommends
+ bundles
+ resources
};
-sub Meta { shift }
-sub Meta_ScalarKeys { @scalar_keys }
-sub Meta_TupleKeys { @tuple_keys }
-
-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 (@tuple_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} unless @_;
-
- my @rv;
- while (@_) {
- my $module = shift or last;
- my $version = shift || 0;
- if ( $module eq 'perl' ) {
- $version =~ s{^(\d+)\.(\d+)\.(\d+)}
- {$1 + $2/1_000 + $3/1_000_000}e;
- $self->perl_version($version);
- next;
- }
- my $rv = [ $module, $version ];
- push @rv, $rv;
- }
- push @{ $self->{values}{$key} }, @rv;
- @rv;
- };
+my @resource_keys = qw{
+ homepage
+ bugtracker
+ repository
+};
+
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+sub Meta_ResourceKeys { @resource_keys }
+
+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 ( @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;
+ };
}
-# configure_requires is currently a null-op
-sub configure_requires { 1 }
+# 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(@_) }
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
@@ -71,266 +118,393 @@
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub sign {
- my $self = shift;
- return $self->{'values'}{'sign'} if defined wantarray and ! @_;
- $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
- return $self;
+ my $self = shift;
+ return $self->{values}{sign} if defined wantarray and ! @_;
+ $self->{values}{sign} = ( @_ ? $_[0] : 1 );
+ return $self;
}
sub dynamic_config {
my $self = shift;
unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
+ warn "You MUST provide an explicit true/false value to dynamic_config\n";
return $self;
}
- $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
- return $self;
+ $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
+ return 1;
+}
+
+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 reall 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 license {
+ my $self = shift;
+ return $self->{values}{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $self->{values}{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license eq 'perl' ) {
+ $self->resources( license => 'http://dev.perl.org/licenses/' );
+ }
+
+ return 1;
}
sub all_from {
- my ( $self, $file ) = @_;
+ 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;
- die "all_from: cannot find $file from $name" unless -e $file;
- }
-
- $self->version_from($file) unless $self->version;
- $self->perl_version_from($file) unless $self->perl_version;
-
- # The remaining probes read from POD sections; if the file
- # has an accompanying .pod, use that instead
- my $pod = $file;
- if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
- $file = $pod;
- }
-
- $self->author_from($file) unless $self->author;
- $self->license_from($file) unless $self->license;
- $self->abstract_from($file) unless $self->abstract;
+ 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");
+ }
+
+ # 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;
+ 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 || {} });
+ 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
- ]
- );
+ 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 = \@_;
+ }
- return @$features;
+ 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} }
- : ();
+ 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};
+ 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', 0 );
+ my $self = shift;
+ $self->include_deps( 'YAML::Tiny', 0 );
- require YAML;
- my $data = YAML::LoadFile('META.yml');
+ 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;
+ # 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;
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
}
sub version_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->version( ExtUtils::MM_Unix->parse_version($file) );
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->abstract(
- bless(
- { DISTNAME => $self->name },
- 'ExtUtils::MM_Unix'
- )->parse_abstract($file)
- );
-}
-
-sub _slurp {
- my ( $self, $file ) = @_;
-
- local *FH;
- open FH, "< $file" or die "Cannot open $file.pod: $!";
- do { local $/; <FH> };
+ 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 perl_version_from {
- my ( $self, $file ) = @_;
-
- if (
- $self->_slurp($file) =~ m/
- ^
- use \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- )
- {
- my $v = $1;
- $v =~ s{_}{}g;
- $self->perl_version($1);
- }
- else {
- warn "Cannot determine perl version info from $file\n";
- return;
- }
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ ^
+ (?:use|require) \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ ) {
+ my $perl_version = $1;
+ $perl_version =~ s{_}{}g;
+ $self->perl_version($perl_version);
+ } else {
+ warn "Cannot determine perl version info from $_[0]\n";
+ return;
+ }
}
sub author_from {
- my ( $self, $file ) = @_;
- my $content = $self->_slurp($file);
- 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;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- $self->author($author);
- }
- else {
- warn "Cannot determine author info from $file\n";
- }
+ 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;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ } else {
+ warn "Cannot determine author info from $_[0]\n";
+ }
}
sub license_from {
- my ( $self, $file ) = @_;
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ (
+ =head \d \s+
+ (?:licen[cs]e|licensing|copyright|legal)\b
+ .*?
+ )
+ (=head\\d.*|=cut.*|)
+ \z
+ /ixms ) {
+ my $license_text = $1;
+ my @phrases = (
+ 'under the same (?:terms|license) as perl itself' => '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,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+}
- if (
- $self->_slurp($file) =~ m/
- (
- =head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
- .*?
- )
- (=head\\d.*|=cut.*|)
- \z
- /ixms
- )
- {
- my $license_text = $1;
- my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser public license' => 'gpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
- if ( $license_text =~ /\b$pattern\b/i ) {
- if ( $osi and $license_text =~ /All rights reserved/i ) {
- warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
+sub bugtracker_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
+ unless ( @links ) {
+ warn "Cannot determine bugtracker info from $_[0]\n";
+ return 0;
+ }
+ if ( @links > 1 ) {
+ warn "Found more than on rt.cpan.org link in $_[0]\n";
+ return 0;
+ }
+
+ # Set the bugtracker
+ bugtracker( $links[0] );
+ return 1;
+}
+
+# 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) ) {
+ $v = $v + 0; # Numify
+ }
+ return $v;
+}
+
+
+
+
+
+######################################################################
+# MYMETA.yml Support
+
+sub WriteMyMeta {
+ $_[0]->write_mymeta;
+}
+
+sub write_mymeta {
+ my $self = shift;
+
+ # If there's no existing META.yml there is nothing we can do
+ return unless -f 'META.yml';
+
+ # 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
}
- $self->license($license);
- return 1;
- }
- }
- }
+ unshift @$requires, [ perl => $perl ];
+ }
+
+ # Load the advisory META.yml file
+ require YAML::Tiny;
+ my @yaml = YAML::Tiny::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} } };
+ }
- warn "Cannot determine license info from $file\n";
- return 'unknown';
+ # Save as the MYMETA.yml file
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
1;
Modified: Jifty-DBI/branches/tisql/inc/Module/Install/Win32.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install/Win32.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install/Win32.pm Sat Jul 18 08:33:37 2009
@@ -4,11 +4,11 @@
use strict;
use Module::Install::Base;
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
- $ISCORE = 1;
+ $VERSION = '0.79';
@ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
@@ -16,7 +16,7 @@
my $self = shift;
$self->load('can_run');
$self->load('get_file');
-
+
require Config;
return unless (
$^O eq 'MSWin32' and
@@ -38,8 +38,7 @@
remove => 1,
);
- if (!$rv) {
- die <<'END_MESSAGE';
+ die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
@@ -59,7 +58,7 @@
-------------------------------------------------------------------------------
END_MESSAGE
- }
+
}
1;
Modified: Jifty-DBI/branches/tisql/inc/Module/Install/WriteAll.pm
==============================================================================
--- Jifty-DBI/branches/tisql/inc/Module/Install/WriteAll.pm (original)
+++ Jifty-DBI/branches/tisql/inc/Module/Install/WriteAll.pm Sat Jul 18 08:33:37 2009
@@ -4,40 +4,37 @@
use strict;
use Module::Install::Base;
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
- $ISCORE = 1;
+ $VERSION = '0.79';
@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->Meta->write if $args{meta};
- $self->admin->WriteAll(%args) if $self->is_admin;
-
- if ( $0 =~ /Build.PL$/i ) {
- $self->Build->write;
- } else {
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{'PL_FILES'} ) {
- $self->makemaker_args( PL_FILES => {} );
- }
- if ($args{inline}) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
- }
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_,
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{PL_FILES} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
+
+ if ( $args{inline} ) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
}
1;
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI.pm Sat Jul 18 08:33:37 2009
@@ -2,7 +2,7 @@
use warnings;
use strict;
-$Jifty::DBI::VERSION = '0.53';
+$Jifty::DBI::VERSION = '0.58';
=head1 NAME
@@ -205,7 +205,7 @@
=head1 LICENSE
-Jifty::DBI is Copyright 2005-2008 Best Practical Solutions, LLC.
+Jifty::DBI is Copyright 2005-2009 Best Practical Solutions, LLC.
Jifty::DBI is distributed under the same terms as Perl itself.
=cut
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI/Collection.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI/Collection.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI/Collection.pm Sat Jul 18 08:33:37 2009
@@ -434,24 +434,6 @@
}
}
-# LIMIT clauses are used for restricting ourselves to subsets of the
-# search.
-sub _limit_clause {
- my $self = shift;
- my $limit_clause;
-
- if ( $self->rows_per_page ) {
- $limit_clause = " LIMIT ";
- if ( $self->first_row != 0 ) {
- $limit_clause .= $self->first_row . ", ";
- }
- $limit_clause .= $self->rows_per_page;
- } else {
- $limit_clause = "";
- }
- return $limit_clause;
-}
-
=head2 _is_limited
If we've limited down this search, return true. Otherwise, return
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI/Column.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI/Column.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI/Column.pm Sat Jul 18 08:33:37 2009
@@ -37,6 +37,7 @@
my @handy_attrs = qw/
container
label hints render_as
+ display_length
documentation
valid_values
available_values
@@ -155,6 +156,8 @@
=item label hints render_as
+=item display_length
+
=item valid_values
=item available_values
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle.pm Sat Jul 18 08:33:37 2009
@@ -238,6 +238,21 @@
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
@@ -510,17 +525,16 @@
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 "$self couldn't prepare the query '$query_string'"
- . $self->dbh->errstr . "\n";
+ die "$message\n";
} else {
- warn "$self couldn't prepare the query '$query_string'"
- . $self->dbh->errstr . "\n";
+ warn "$message\n";
my $ret = Class::ReturnValue->new();
$ret->as_error(
errno => '-1',
- message => "Couldn't prepare the query '$query_string'."
- . $self->dbh->errstr,
+ message => $message,
do_backtrace => undef
);
return ( $ret->return_value );
@@ -1327,21 +1341,6 @@
}
-=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 canonical_true
This returns the canonical true value for this database. For example, in SQLite
@@ -1364,6 +1363,94 @@
sub canonical_false { 0 }
+=head2 Schema manipulation methods
+
+=head3 rename_column
+
+Rename a column in a table. Takes 'table', 'column' and new name in 'to'.
+
+=cut
+
+sub rename_column {
+ my $self = shift;
+ my %args = (table => undef, column => undef, to => undef, @_);
+# Oracle: since Oracle 9i R2
+# Pg: 7.4 can this and may be earlier
+ return $self->simple_query(
+ "ALTER TABLE $args{'table'} RENAME COLUMN $args{'column'} TO $args{'to'}"
+ );
+}
+
+
+=head3 rename_table
+
+Renames a table in the DB. Takes 'table' and new name of it in 'to'.
+
+=cut
+
+sub rename_table {
+ my $self = shift;
+ my %args = (table => undef, to => undef, @_);
+# mysql has RENAME TABLE, but alter can rename temporary
+# Oracle, Pg, SQLite are ok with this
+ return $self->simple_query("ALTER TABLE $args{'table'} RENAME TO $args{'to'}");
+}
+
+=head2 supported_drivers
+
+Returns a list of the drivers L<Jifty::DBI> supports.
+
+=cut
+
+sub supported_drivers {
+ return qw(
+ SQLite
+ Informix
+ mysql
+ mysqlPP
+ ODBC
+ Oracle
+ Pg
+ Sybase
+ );
+}
+
+=head2 available_drivers
+
+Returns a list of the available drivers based on the presence of C<DBD::*>
+modules.
+
+=cut
+
+sub available_drivers {
+ my $self = shift;
+
+ local $@;
+ return grep { eval "require DBD::" . $_ } $self->supported_drivers;
+}
+
+=head2 is_available_driver
+
+Returns a boolean indicating whether the provided driver is available.
+
+=cut
+
+do {
+ # lazily memoize
+ my $is_available_driver;
+
+ sub is_available_driver {
+ my $self = shift;
+ my $driver = shift;
+
+ if (!$is_available_driver) {
+ %$is_available_driver = map { $_ => 1 } $self->available_drivers;
+ }
+
+ return $is_available_driver->{$driver};
+ }
+};
+
=head2 DESTROY
When we get rid of the L<Jifty::DBI::Handle>, we need to disconnect
@@ -1373,7 +1460,17 @@
sub DESTROY {
my $self = shift;
- $self->disconnect;
+
+ # eval in DESTROY can cause $@ issues elsewhere
+ local $@;
+
+ $self->disconnect
+ unless $self->dbh
+ and $self->dbh
+ # We use an eval {} because DESTROY order during
+ # global destruction is not guaranteed -- the dbh may
+ # no longer be tied, which throws an error.
+ and eval { $self->dbh->{InactiveDestroy} };
delete $DBIHandle{$self};
}
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle/SQLite.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle/SQLite.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle/SQLite.pm Sat Jul 18 08:33:37 2009
@@ -98,6 +98,70 @@
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;
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle/mysql.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle/mysql.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI/Handle/mysql.pm Sat Jul 18 08:33:37 2009
@@ -81,6 +81,39 @@
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__
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI/HasFilters.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI/HasFilters.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI/HasFilters.pm Sat Jul 18 08:33:37 2009
@@ -43,11 +43,11 @@
my $self = shift;
if (@_) { # setting
my @values = map { UNIVERSAL::isa( $_, 'ARRAY' ) ? @$_ : $_ } @_;
- $self->_input_filters_accessor( \@values );
+ $self->{input_filters} = \@values;
return @values;
}
- return @{ $self->_input_filters_accessor || [] };
+ return @{ $self->{input_filters} || [] };
}
=head2 output_filters
@@ -64,11 +64,11 @@
my $self = shift;
if (@_) { # setting
my @values = map { UNIVERSAL::isa( $_, 'ARRAY' ) ? @$_ : $_ } @_;
- $self->_output_filters_accessor( \@values );
+ $self->{output_filters} = \@values;
return @values;
}
- my $values = $self->_output_filters_accessor;
+ my $values = $self->{output_filters};
return @$values if $values && @$values;
return reverse $self->input_filters;
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI/Record.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI/Record.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI/Record.pm Sat Jul 18 08:33:37 2009
@@ -9,6 +9,7 @@
use UNIVERSAL::require ();
use Scalar::Util qw(blessed);
use Class::Trigger; # exports by default
+use Scalar::Defer 'force';
use base qw/
Class::Data::Inheritable
@@ -1416,7 +1417,11 @@
and defined $column->default
and not ref $column->default )
{
- $attribs{ $column->name } = $column->default;
+ my $default = force $column->default;
+ $default = $default->id
+ if UNIVERSAL::isa( $default, 'Jifty::DBI::Record' );
+
+ $attribs{ $column->name } = $default;
$self->_apply_input_filters(
column => $column,
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI/Schema.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI/Schema.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI/Schema.pm Sat Jul 18 08:33:37 2009
@@ -101,14 +101,17 @@
use Exporter::Lite ();
# TODO - This "sub import" is strictly here to catch the deprecated "length is 40".
-# Once the deprecation cycle is over we should take this away and rever to
-# "use Exporter::Lite" in the line above.
+# Once the deprecation cycle is over we should take the SIGDIE swapping away
my $old_sig_die;
sub import {
no warnings qw( uninitialized numeric );
$old_sig_die ||= $SIG{__DIE__};
$SIG{__DIE__} = \&filter_die unless $SIG{__DIE__} and $SIG{__DIE__} == \&filter_die;
+
+ strict->import;
+ warnings->import;
+
goto &Exporter::Lite::import;
}
@@ -711,6 +714,12 @@
might go in this column. Correct usage is C<hints is 'Used by the
frobnicator to do strange things'>.
+=head2 display_length
+
+The displayed length of form fields. Though you may be able to fit
+500 characters in the field, you would not want to display an HTML
+form with a size 500 input box.
+
=head2 render_as
Used in user interface generation to know how to render the column.
Modified: Jifty-DBI/branches/tisql/lib/Jifty/DBI/SchemaGenerator.pm
==============================================================================
--- Jifty-DBI/branches/tisql/lib/Jifty/DBI/SchemaGenerator.pm (original)
+++ Jifty-DBI/branches/tisql/lib/Jifty/DBI/SchemaGenerator.pm Sat Jul 18 08:33:37 2009
@@ -279,7 +279,9 @@
# Encode default values
my $default = $column->default;
- if (defined $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,
Modified: Jifty-DBI/branches/tisql/t/02searches_joins.t
==============================================================================
--- Jifty-DBI/branches/tisql/t/02searches_joins.t (original)
+++ Jifty-DBI/branches/tisql/t/02searches_joins.t Sat Jul 18 08:33:37 2009
@@ -221,7 +221,6 @@
}
cleanup_schema( 'TestApp', $handle );
- disconnect_handle($handle);
}} # SKIP, foreach blocks
1;
Added: Jifty-DBI/branches/tisql/t/03rename_column.t
==============================================================================
--- (empty file)
+++ Jifty-DBI/branches/tisql/t/03rename_column.t Sat Jul 18 08:33:37 2009
@@ -0,0 +1,65 @@
+#!/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;
Added: Jifty-DBI/branches/tisql/t/03rename_table.t
==============================================================================
--- (empty file)
+++ Jifty-DBI/branches/tisql/t/03rename_table.t Sat Jul 18 08:33:37 2009
@@ -0,0 +1,53 @@
+#!/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;
Added: Jifty-DBI/branches/tisql/t/06filter_salthash.t
==============================================================================
--- (empty file)
+++ Jifty-DBI/branches/tisql/t/06filter_salthash.t Sat Jul 18 08:33:37 2009
@@ -0,0 +1,104 @@
+#!/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 {
+
+<<EOF;
+CREATE table users (
+ id integer primary key,
+ password text
+)
+EOF
+
+}
+
+sub schema_mysql {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id integer auto_increment primary key,
+ password text
+)
+EOF
+
+}
+
+sub schema_pg {
+
+<<EOF;
+CREATE TEMPORARY table users (
+ id serial primary key,
+ password text
+)
+EOF
+
+}
+
+BEGIN {
+ use Jifty::DBI::Schema;
+
+ use Jifty::DBI::Record schema {
+ column password =>
+ type is 'text',
+ filters are qw/ Jifty::DBI::Filter::SaltHash /;
+ }
+}
+
Modified: Jifty-DBI/branches/tisql/t/utils.pl
==============================================================================
--- Jifty-DBI/branches/tisql/t/utils.pl (original)
+++ Jifty-DBI/branches/tisql/t/utils.pl Sat Jul 18 08:33:37 2009
@@ -2,6 +2,7 @@
use strict;
use File::Temp ();
+use Jifty::DBI::Handle;
=head1 VARIABLES
@@ -11,19 +12,7 @@
=cut
-our @supported_drivers = qw(
- SQLite
- Informix
- mysql
- mysqlPP
- ODBC
- Oracle
- Pg
- Sybase
-);
-
-
-
+our @supported_drivers = Jifty::DBI::Handle->supported_drivers;
=head2 @available_drivers
@@ -32,9 +21,9 @@
=cut
-our @available_drivers = grep { eval "require DBD::". $_ } @supported_drivers;
+our @available_drivers = Jifty::DBI::Handle->available_drivers;
-=head1 functionS
+=head1 FUNCTIONS
=head2 get_handle
@@ -288,6 +277,24 @@
=head2 init_data
+Takes a class to get data from and the handle, calls C<init_data>
+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 at localhost'],
+ ...
+ ) }
+
=cut
sub init_data
@@ -309,4 +316,27 @@
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;
More information about the Jifty-commit
mailing list