r44823 - in /trunk/librose-db-object-perl: ./ debian/ lib/Rose/DB/ lib/Rose/DB/Object/ lib/Rose/DB/Object/MakeMethods/ t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Fri Sep 25 18:06:39 UTC 2009
Author: jawnsy-guest
Date: Fri Sep 25 18:06:24 2009
New Revision: 44823
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=44823
Log:
* New upstream release
* Small cleanup to rules file
* Remove some unnecessary version dependencies
* Standards-Version 3.8.3 (drop perl version dependency)
Added:
trunk/librose-db-object-perl/t/multi-many-the-hard-way.t
- copied unchanged from r44818, branches/upstream/librose-db-object-perl/current/t/multi-many-the-hard-way.t
Modified:
trunk/librose-db-object-perl/Changes
trunk/librose-db-object-perl/MANIFEST
trunk/librose-db-object-perl/META.yml
trunk/librose-db-object-perl/debian/changelog
trunk/librose-db-object-perl/debian/control
trunk/librose-db-object-perl/debian/rules
trunk/librose-db-object-perl/lib/Rose/DB/Object.pm
trunk/librose-db-object-perl/lib/Rose/DB/Object/Helpers.pm
trunk/librose-db-object-perl/lib/Rose/DB/Object/MakeMethods/Generic.pm
trunk/librose-db-object-perl/lib/Rose/DB/Object/Manager.pm
trunk/librose-db-object-perl/lib/Rose/DB/Object/QueryBuilder.pm
trunk/librose-db-object-perl/t/as-tree.t
trunk/librose-db-object-perl/t/db-object-helpers.t
trunk/librose-db-object-perl/t/db-object-manager.t
trunk/librose-db-object-perl/t/db-object.t
Modified: trunk/librose-db-object-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/Changes?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/Changes (original)
+++ trunk/librose-db-object-perl/Changes Fri Sep 25 18:06:24 2009
@@ -1,3 +1,23 @@
+0.783 (09.14.2009) - John Siracusa <siracusa at gmail.com>
+
+ * Added new range operators: between, gt_lt, gt_le, ge_lt, and ge_le.
+ * The strip() helper method will now throw an exception when there are
+ pending "on-save" actions. (Reported by Kevin McGrath)
+ * Added strip_on_save_ok parameter to strip() to override the default
+ behavior.
+ * Worked around yet another MySQL empty-string-default "feature."
+ (Reported by Terrence Brannon)
+ * Added missing documentation about the required return value of the
+ "object" handler in the traverse_depth_first() helper method.
+ (Reported by David Christensen)
+ * The traverse_depth_first() helper now preserves the existing context
+ object if a "relationship" handler is not defined. (Reported by
+ David Christensen)
+ * Fixed a bug that prevented scalar reference filter arguments from working
+ correctly with date columns in Manager queries. (Reported by Todd Lyons)
+ * Fixed a multi-many Manager bug that caused duplicate sub-objects to be
+ linked to the wrong parent object. (Reported by Anton Shevchenko)
+
0.782 (07.09.2009) - John Siracusa <siracusa at gmail.com>
* Altered tests to confirm the fix for RT 45836.
Modified: trunk/librose-db-object-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/MANIFEST?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/MANIFEST (original)
+++ trunk/librose-db-object-perl/MANIFEST Fri Sep 25 18:06:24 2009
@@ -167,6 +167,7 @@
t/make-modules.ext
t/make-modules.t
t/map-record-name-conflict.pl
+t/multi-many-the-hard-way.t
t/multi-pk-sequences.t
t/nested-joins.t
t/one-to-many-reset.t
Modified: trunk/librose-db-object-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/META.yml?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/META.yml (original)
+++ trunk/librose-db-object-perl/META.yml Fri Sep 25 18:06:24 2009
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Rose-DB-Object
-version: 0.782
+version: 0.783
abstract: Extensible, high performance object-relational mapper (ORM).
author:
- John Siracusa <siracusa at gmail.com>
@@ -38,7 +38,7 @@
directory:
- t
- inc
-generated_by: ExtUtils::MakeMaker version 6.52
+generated_by: ExtUtils::MakeMaker version 6.54
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
Modified: trunk/librose-db-object-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/debian/changelog?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/debian/changelog (original)
+++ trunk/librose-db-object-perl/debian/changelog Fri Sep 25 18:06:24 2009
@@ -1,9 +1,16 @@
-librose-db-object-perl (1:0.782-2) UNRELEASED; urgency=low
+librose-db-object-perl (1:0.783-1) UNRELEASED; urgency=low
+ [ Jonathan Yu ]
+ * New upstream release
+ * Small cleanup to rules file
+ * Remove some unnecessary version dependencies
+ * Standards-Version 3.8.3 (drop perl version dependency)
+
+ [ Ryan Niebur ]
* Update jawnsy's email address
* Update ryan52's email address
- -- Ryan Niebur <ryan at debian.org> Fri, 25 Sep 2009 00:26:11 -0700
+ -- Jonathan Yu <jawnsy at cpan.org> Fri, 25 Sep 2009 09:39:02 -0400
librose-db-object-perl (1:0.782-1) unstable; urgency=low
Modified: trunk/librose-db-object-perl/debian/control
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/debian/control?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/debian/control (original)
+++ trunk/librose-db-object-perl/debian/control Fri Sep 25 18:06:24 2009
@@ -2,8 +2,8 @@
Section: perl
Priority: optional
Build-Depends: debhelper (>= 7.0.50)
-Build-Depends-Indep: perl (>= 5.8.8-7), libdatetime-perl, libbit-vector-perl,
- librose-db-perl (>= 0.753), liblist-moreutils-perl, libdbi-perl (>= 1.4),
+Build-Depends-Indep: perl, libdatetime-perl, libbit-vector-perl,
+ librose-db-perl (>= 0.753), liblist-moreutils-perl, libdbi-perl,
libclone-perl (>= 0.29), librose-object-perl (>= 0.854), libtest-pod-perl,
libdbd-sqlite3-perl
Maintainer: Debian Perl Group <pkg-perl-maintainers at lists.alioth.debian.org>
@@ -11,15 +11,15 @@
Brian Cassidy <brian.cassidy at gmail.com>, gregor herrmann <gregoa at debian.org>,
Rene Mayorga <rmayorga at debian.org>, Ryan Niebur <ryan at debian.org>,
Jonathan Yu <jawnsy at cpan.org>
+Standards-Version: 3.8.3
Homepage: http://search.cpan.org/dist/Rose-DB-Object/
Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/librose-db-object-perl/
Vcs-Browser: http://svn.debian.org/viewsvn/pkg-perl/trunk/librose-db-object-perl/
-Standards-Version: 3.8.2
Package: librose-db-object-perl
Architecture: all
-Depends: ${perl:Depends}, ${misc:Depends}, libdatetime-perl, libbit-vector-perl,
- libclone-perl (>= 0.29), liblist-moreutils-perl, libdbi-perl (>= 1.4),
+Depends: ${perl:Depends}, ${misc:Depends}, libdatetime-perl, libbit-vector-perl,
+ libclone-perl (>= 0.29), liblist-moreutils-perl, libdbi-perl,
librose-db-perl (>= 0.753), librose-object-perl (>= 0.854)
Description: Perl framework providing an extensible high-performance ORM
Rose::DB::Object is a base class for objects that encapsulate a single row in
Modified: trunk/librose-db-object-perl/debian/rules
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/debian/rules?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/debian/rules (original)
+++ trunk/librose-db-object-perl/debian/rules Fri Sep 25 18:06:24 2009
@@ -1,8 +1,11 @@
#!/usr/bin/make -f
+
+PACKAGE = $(shell dh_listpackages)
+TMP = $(CURDIR)/debian/$(PACKAGE)
%:
dh $@
override_dh_fixperms:
dh_fixperms
- chmod 644 $(CURDIR)/debian/librose-db-object-perl/usr/share/perl5/Rose/DB/Object/Tutorial.pod
+ chmod 644 $(TMP)/usr/share/perl5/Rose/DB/Object/Tutorial.pod
Modified: trunk/librose-db-object-perl/lib/Rose/DB/Object.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/lib/Rose/DB/Object.pm?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/lib/Rose/DB/Object.pm (original)
+++ trunk/librose-db-object-perl/lib/Rose/DB/Object.pm Fri Sep 25 18:06:24 2009
@@ -16,7 +16,7 @@
use Rose::DB::Object::Exception;
use Rose::DB::Object::Util();
-our $VERSION = '0.782';
+our $VERSION = '0.783';
our $Debug = 0;
Modified: trunk/librose-db-object-perl/lib/Rose/DB/Object/Helpers.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/lib/Rose/DB/Object/Helpers.pm?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/lib/Rose/DB/Object/Helpers.pm (original)
+++ trunk/librose-db-object-perl/lib/Rose/DB/Object/Helpers.pm Fri Sep 25 18:06:24 2009
@@ -11,7 +11,7 @@
use Carp;
-our $VERSION = '0.776';
+our $VERSION = '0.783';
__PACKAGE__->export_tags
(
@@ -554,9 +554,41 @@
delete $self->{'db'};
}
+ # Strip "on-save" code references: destructive!
+ unless($args{'strip_on_save_ok'})
+ {
+ if(__contains_code_ref($self->{ON_SAVE_ATTR_NAME()}))
+ {
+ croak qq(Refusing to strip "on-save" actions from ), ref($self),
+ qq( object without strip_on_save_ok parameter);
+ }
+ }
+
+ delete $self->{ON_SAVE_ATTR_NAME()};
+
+ # Reference to metadata object will be regenrated as needed
delete $self->{META_ATTR_NAME()};
return $self;
+}
+
+sub __contains_code_ref
+{
+ my($hash_ref) = shift;
+
+ foreach my $key (keys %$hash_ref)
+ {
+ return 1 if(ref $hash_ref->{$key} eq 'CODE');
+
+ if(ref $hash_ref->{$key} eq 'HASH')
+ {
+ return 1 if(__contains_code_ref($hash_ref->{$key}));
+ }
+ else
+ {
+ Carp::confess "Unexpected reference encountered: $hash_ref->{$key}";
+ }
+ }
}
# XXX: A value that is unlikely to exist in a primary key column value
@@ -663,7 +695,8 @@
$objs = [ $objs ] unless(ref $objs eq 'ARRAY');
}
- my $c = $handlers->{'relationship'}->($self, $context, $rel) if($handlers->{'relationship'});
+ my $c = $handlers->{'relationship'} ?
+ $handlers->{'relationship'}->($self, $context, $rel) : $context;
OBJ: foreach my $obj (@$objs)
{
@@ -763,7 +796,7 @@
}
# XXX: This version requires all relationship and column mutators to have
-# XXX: the same names as the relationships and columnsthemselves.
+# XXX: the same names as the relationships and columns themselves.
# sub init_with_tree { shift->init(@_) }
# XXX: This version requires all relationship mutators to have the same
@@ -1345,6 +1378,10 @@
This method prepares an object for serialization by stripping out internal structures known to contain code references or other values that do not survive serialization. The object itself is returned, now stripped.
+B<Note:> Operations that were scheduled to happen "on L<save()|Rose::DB::Object/save>" will I<also> be stripped out by this method. Examples include the databsae update or insertion of any child objects attached to the parent object using C<get_set_on_save>, C<add_on_save>, or C<delete_on_save> methods. If such operations exist, an exception will be thrown unless the C<strip_on_save_ok> parameter is true.
+
+If your object has these kinds of pending changes, either L<save()|Rose::DB::Object/save> first and then L<strip()|/strip>, or L<clone()|/clone> and then L<strip()|/strip> the clone.
+
By default, the L<db|Rose::DB::Object/db> object and all sub-objects (foreign keys or relationships) are removed. PARAMS are optional name/value pairs. Valid PARAMS are:
=over 4
@@ -1372,6 +1409,10 @@
Do not remove any sub-objects (L<foreign keys|Rose::DB::Object::Metadata/foreign_keys> or L<relationships|Rose::DB::Object::Metadata/relationships>) that have L<already been loaded|/has_loaded_related> by this object. This option is the same as specifying both the C<foreign_keys> and C<relationships> names.
=back
+
+=item B<strip_on_save_ok BOOL>
+
+If true, do not throw an exception when pending "on-save" changes exist in the object; just strip them. (See description above for details.)
=back
@@ -1413,7 +1454,9 @@
=item B<object>
-This handler is called whenever a L<Rose::DB::Object>-derived object is encountered. This includes the object that L<traverse_depth_first|/traverse_depth_first> was called on as well as any sub-objects. The handler is passed the object, the C<context>, the parent object (undef, if none), the L<Rose::DB::Object::Metadata::Relationship>-derived object through which this object was arrived at (undef if none), and the depth. Example:
+This handler is called whenever a L<Rose::DB::Object>-derived object is encountered. This includes the object that L<traverse_depth_first|/traverse_depth_first> was called on as well as any sub-objects. The handler is passed the object, the C<context>, the parent object (undef, if none), the L<Rose::DB::Object::Metadata::Relationship>-derived object through which this object was arrived at (undef if none), and the depth.
+
+The handler I<must> return the value to be used as the C<context> during the traversal of any related sub-objects. The context returned may be different than the context passed in. Example:
handlers =>
{
@@ -1421,6 +1464,8 @@
{
my($object, $context, $parent, $rel_meta, $depth) = @_;
...
+
+ return $context; # Important!
}
...
}
@@ -1429,7 +1474,7 @@
This handler is called just before a L<Rose::DB::Object::Metadata::Relationship>-derived object is descended into (i.e., just before the sub-objectes related through this relationship are processed). The handler is passed the object that contains the relationship, the C<context>, the C<context>, and the L<relationship|Rose::DB::Object::Metadata::Relationship> object itself.
-The handler I<must> return the value to be used as the C<context> during the traversal of the objects related through this relationship. The context returned may be different than the context passed in. Example:
+The handler I<must> return the value to be used as the C<context> during the traversal of the objects related through this relationship. (If you do not define this handler, then the current context object will be used.) The context returned may be different than the context passed in. Example:
handlers =>
{
Modified: trunk/librose-db-object-perl/lib/Rose/DB/Object/MakeMethods/Generic.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/lib/Rose/DB/Object/MakeMethods/Generic.pm?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/lib/Rose/DB/Object/MakeMethods/Generic.pm (original)
+++ trunk/librose-db-object-perl/lib/Rose/DB/Object/MakeMethods/Generic.pm Fri Sep 25 18:06:24 2009
@@ -20,7 +20,7 @@
use Rose::DB::Object::Helpers();
use Rose::DB::Object::Util qw(column_value_formatted_key);
-our $VERSION = '0.781';
+our $VERSION = '0.783';
our $Debug = 0;
@@ -422,6 +422,10 @@
my %values = map { $_ => 1 } @$values;
my $default = $args->{'default'};
+
+ # Good-old MySQL and its empty-string defaults for NOT NULL columns...
+ no warnings 'uninitialized';
+ delete $args->{'default'} if($default eq '' && !$values{$default});
if(exists $args->{'default'})
{
Modified: trunk/librose-db-object-perl/lib/Rose/DB/Object/Manager.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/lib/Rose/DB/Object/Manager.pm?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/lib/Rose/DB/Object/Manager.pm (original)
+++ trunk/librose-db-object-perl/lib/Rose/DB/Object/Manager.pm Fri Sep 25 18:06:24 2009
@@ -832,6 +832,8 @@
# not count towards the multi_many_ok warning.
my $num_to_many_rels_adjustment = 0;
+ my($multi_many, @subobject_method_map);
+
if($with_objects)
{
# XXX: Hack to avoid suprious ORA-00918 errors
@@ -946,11 +948,13 @@
$num_to_many_rels = grep { defined $_ } @has_dups;
+ # Adjust for explicitly included map_record tables, which should
+ # not count towards the multi_many_ok warning.
+ $multi_many = (($num_to_many_rels - $num_to_many_rels_adjustment) > 1) ? 1 : 0;
+
unless($args{'multi_many_ok'})
{
- # Adjust for explicitly included map_record tables, which should
- # not count towards the multi_many_ok warning.
- if(($num_to_many_rels - $num_to_many_rels_adjustment) > 1)
+ if($multi_many)
{
Carp::carp
qq(WARNING: Fetching sub-objects via more than one ),
@@ -1108,6 +1112,13 @@
{
# Aliased table names
push(@{$joins[$i]{'conditions'}}, "t${parent_tn}.$local_column = t$i.$foreign_column");
+
+ if($multi_many)
+ {
+ my $local_method = $parent_meta->column_mutator_method_name($local_column);
+ my $foreign_method = $ft_meta->column_accessor_method_name($foreign_column);
+ push(@{$subobject_method_map[$belongs_to[$i - 1]]}, [ $local_method, $foreign_method ]);
+ }
# Fully-qualified table names
#push(@{$joins[$i]{'conditions'}}, "$tables[0].$local_column = $tables[-1].$foreign_column");
@@ -2248,6 +2259,32 @@
#$subobjects_belong_to[$i] = $#{$sub_objects[$bt]};
my $parent_object = $sub_objects[$bt];
+
+ # XXX: Special heavyweight subobject pairing in multi-many queries
+ if($multi_many && ref $parent_object eq 'ARRAY' && @$parent_object > 1)
+ {
+ my $maps = $subobject_method_map[$bt];
+ my %check;
+
+ foreach my $map (@$maps)
+ {
+ my $subobject_method = $map->[1];
+ $check{$subobject_method} = $subobject->$subobject_method();
+ }
+
+ PARENT: foreach my $check_parent (reverse @$parent_object)
+ {
+ foreach my $map (@$maps)
+ {
+ my $parent_method = $map->[0];
+ next PARENT unless($check_parent->$parent_method() eq $check{$map->[1]});
+ }
+
+ $parent_object = $check_parent;
+ last PARENT;
+ }
+ }
+
# XXX: This relies on parent objects coming before child
# objects in the list of tables in the FROM clause.
$parent_object = $parent_object->[-1] #$parent_object->[$subobjects_belong_to[$i]]
@@ -2737,6 +2774,32 @@
#$subobjects_belong_to[$i] = $#{$sub_objects[$bt]};
my $parent_object = $sub_objects[$bt];
+
+ # XXX: Special heavyweight subobject pairing in multi-many queries
+ if($multi_many && ref $parent_object eq 'ARRAY' && @$parent_object > 1)
+ {
+ my $maps = $subobject_method_map[$bt];
+ my %check;
+
+ foreach my $map (@$maps)
+ {
+ my $subobject_method = $map->[1];
+ $check{$subobject_method} = $subobject->$subobject_method();
+ }
+
+ PARENT: foreach my $check_parent (reverse @$parent_object)
+ {
+ foreach my $map (@$maps)
+ {
+ my $parent_method = $map->[0];
+ next PARENT unless($check_parent->$parent_method() eq $check{$map->[1]});
+ }
+
+ $parent_object = $check_parent;
+ last PARENT;
+ }
+ }
+
# XXX: This relies on parent objects coming before child
# objects in the list of tables in the FROM clause.
$parent_object = $parent_object->[-1] #$parent_object->[$subobjects_belong_to[$i]]
Modified: trunk/librose-db-object-perl/lib/Rose/DB/Object/QueryBuilder.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/lib/Rose/DB/Object/QueryBuilder.pm?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/lib/Rose/DB/Object/QueryBuilder.pm (original)
+++ trunk/librose-db-object-perl/lib/Rose/DB/Object/QueryBuilder.pm Fri Sep 25 18:06:24 2009
@@ -11,11 +11,11 @@
our @EXPORT_OK = qw(build_select build_where_clause);
-our $VERSION = '0.778';
+our $VERSION = '0.783';
our $Debug = 0;
-our %OP_MAP =
+our %Op_Map =
(
similar => 'SIMILAR TO',
match => '~',
@@ -25,6 +25,11 @@
like => 'LIKE',
ilike => 'ILIKE',
rlike => 'RLIKE',
+ between => '%COLUMN% BETWEEN ? AND ?',
+ gt_lt => '(%COLUMN% > ? AND %COLUMN% < ?)',
+ gt_le => '(%COLUMN% > ? AND %COLUMN% <= ?)',
+ ge_lt => '(%COLUMN% >= ? AND %COLUMN% < ?)',
+ ge_le => '(%COLUMN% >= ? AND %COLUMN% <= ?)',
is => 'IS',
is_not => 'IS NOT',
lt => '<',
@@ -71,11 +76,15 @@
ltree_concat => '||',
);
- at OP_MAP{map { $_ . '_sql' } keys %OP_MAP} = values(%OP_MAP);
+our %Template_Op = map { $Op_Map{$_} => 1 } qw(between gt_lt gt_le ge_lt ge_le);
+
+ at Op_Map{map { $_ . '_sql' } keys %Op_Map} = values(%Op_Map);
+
+our %Op_Wantarray = map { $_ => 2 } map { $_, "${_}_sql" } qw(between gt_lt gt_le ge_lt ge_le);
our %Op_Arg_PassThru = map { $_ => 1 }
- qw(similar match imatch regex regexp like ilike rlike in_set any_in_set all_in_set
- in_array any_in_array all_in_array);
+ qw(similar match imatch regex regexp regexp_like like ilike rlike
+ in_set any_in_set all_in_set in_array any_in_array all_in_array);
BEGIN { eval { require DBI::Const::GetInfoType }; }
use constant SQL_DBMS_VER => $DBI::Const::GetInfoType::GetInfoType{'SQL_DBMS_VER'} || 18;
@@ -804,12 +813,12 @@
{
my $op_arg = (keys(%$vals))[0];
- if($op_arg =~ s/_?sql$//)
+ if($op_arg =~ s/(?:_|^)sql$//)
{
$force_inline = 1;
}
- unless($op = $OP_MAP{$op_arg})
+ unless($op = $Op_Map{$op_arg})
{
if($strict_ops)
{
@@ -998,6 +1007,13 @@
foreach my $val (@$vals)
{
+ no warnings 'uninitialized';
+ if(ref $val eq 'SCALAR')
+ {
+ push(@new_vals, $$val);
+ next;
+ }
+
my $should_inline =
($db && $col_meta && $col_meta->should_inline_value($db, $val));
@@ -1017,6 +1033,17 @@
}
}
+ if($Template_Op{$op})
+ {
+ for($op)
+ {
+ s/%COLUMN%/$field/g;
+ s/\?/shift(@new_vals)/ge;
+ }
+
+ return $not ? "NOT ($op)" : $op;
+ }
+
return '(' . join(' OR ', map { ($not ? "$not(" : '') . "$field $op $_" .
($not ? ')' : '') } @new_vals) . ')';
}
@@ -1043,7 +1070,7 @@
foreach my $raw_op (keys(%$vals))
{
- unless($sub_op = $OP_MAP{$raw_op})
+ unless($sub_op = $Op_Map{$raw_op})
{
Carp::croak "Unknown comparison operator: $raw_op" if($strict_ops);
$sub_op = $raw_op;
@@ -1059,9 +1086,21 @@
{
my $tmp_not = $all_in ? 0 : $not;
- foreach my $val (@{$vals->{$raw_op}})
- {
- push(@clauses, _build_clause($dbh, $field, $sub_op, $val, $tmp_not, $field_mod, $bind, $db, $col_meta, $force_inline, $set, $placeholder, $bind_params));
+ if (my $wanted = $Op_Wantarray{$raw_op})
+ {
+ if($wanted > 1 && @{$vals->{$raw_op}} > $wanted)
+ {
+ Carp::croak "The '$raw_op' operator expects $wanted arguments, but got ", scalar(@{$vals->{$raw_op}});
+ }
+
+ push(@clauses, _build_clause($dbh, $field, $sub_op, $vals->{$raw_op}, $tmp_not, $field_mod, $bind, $db, $col_meta, $force_inline, $set, $placeholder, $bind_params));
+ }
+ else
+ {
+ foreach my $val (@{$vals->{$raw_op}})
+ {
+ push(@clauses, _build_clause($dbh, $field, $sub_op, $val, $tmp_not, $field_mod, $bind, $db, $col_meta, $force_inline, $set, $placeholder, $bind_params));
+ }
}
}
else
@@ -1228,7 +1267,7 @@
{
foreach my $key (keys %$value)
{
- next if($key =~ /_?sql$/); # skip inline values
+ next if($key =~ /(?:_|^)sql$/); # skip inline values
_format_value($db, $value, $key, $object, $col_meta, $get_method, $set_method, $value->{$key}, 0, $depth + 1, $allow_empty_lists);
}
}
@@ -1239,7 +1278,7 @@
$object->$set_method($value);
$value = $object->$get_method();
}
- elsif(defined $value)
+ elsif(defined $value && $val_ref ne 'SCALAR')
{
my $parsed_value = $col_meta->parse_value($db, $value);
@@ -1401,7 +1440,6 @@
If true, the SQL returned will have slightly nicer formatting.
-
=item B<query PARAMS>
The query parameters, passed as a reference to an array of name/value pairs, scalar references, or array references. PARAMS may include an arbitrary list of selection parameters used to modify the "WHERE" clause of the SQL select statement. Any query parameter that is not in one of the forms described below will cause a fatal error.
@@ -1430,15 +1468,6 @@
# (COLUMN OP 'foo' OR COLUMN OP 'goo')
NAME => { OP => [ "foo", "goo" ] }
-
-If a value is a reference to a scalar, that scalar is "inlined" without any quoting.
-
- 'NAME' => \"foo" # COLUMN = foo
- 'NAME' => [ "a", \"b" ] # COLUMN IN ('a', b)
-
-Undefined values are translated to the keyword NULL when included in a multi-value comparison.
-
- 'NAME' => [ "a", undef ] # COLUMN IN ('a', NULL)
"OP" can be any of the following:
@@ -1460,6 +1489,24 @@
le <=
ge >=
+Ranges:
+
+ NAME => { between => [ 1, 99 ] } # COLUMN BETWEEN 1 AND 99
+
+ NAME => { gt_lt => [ 1, 99 ] } # (COLUMN > 1 AND < 99)
+ NAME => { gt_le => [ 1, 99 ] } # (COLUMN > 1 AND <= 99)
+ NAME => { ge_lt => [ 1, 99 ] } # (COLUMN >= 1 AND < 99)
+ NAME => { ge_le => [ 1, 99 ] } # (COLUMN >= 1 AND <= 99)
+
+If a value is a reference to a scalar, that scalar is "inlined" without any quoting.
+
+ 'NAME' => \"foo" # COLUMN = foo
+ 'NAME' => [ "a", \"b" ] # COLUMN IN ('a', b)
+
+Undefined values are translated to the keyword NULL when included in a multi-value comparison.
+
+ 'NAME' => [ "a", undef ] # COLUMN IN ('a', NULL)
+
Set operations:
### Informix (default) ###
@@ -1538,7 +1585,7 @@
ltree_ltxtquery @
ltree_concat ||
-Any of these operations described above can have "_sql" appended to indicate that the corresponding values are to be "inlined" (i.e., included in the SQL query as-is, with no quoting of any kind). This is useful for comparing two columns. For example, this query:
+Any of the operations described above can have "_sql" appended to indicate that the corresponding values are to be "inlined" (i.e., included in the SQL query as-is, with no quoting of any kind). This is useful for comparing two columns. For example, this query:
query => [ legs => { gt_sql => 'eyes' } ]
Modified: trunk/librose-db-object-perl/t/as-tree.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/t/as-tree.t?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/t/as-tree.t (original)
+++ trunk/librose-db-object-perl/t/as-tree.t Fri Sep 25 18:06:24 2009
@@ -51,8 +51,8 @@
if($Have_Test_Differences)
{
# Test::Differences is sensitive to string/number distinctions that
- # SQLite exhibits and that I don't care about.
- if($db_type eq 'sqlite')
+ # SQLite and Pg exhibit and that I don't care about.
+ if($db_type eq 'sqlite' || $db_type =~ /^pg/)
{
no warnings;
*is_deeply = \&Test::More::is_deeply;
@@ -201,7 +201,7 @@
$tree = $product_class->new(id => 2)->as_tree(force_load => 1, max_depth => 0);
- my $check_tree =
+ my $check_tree =
{
'id' => '2',
'name' => 'Sled',
@@ -1049,7 +1049,7 @@
#die "This test chokes DBD::Pg version 2.1.x and 2.2.0" if($DBD::Pg::VERSION =~ /^2\.(?:1\.|2\.0)/);
};
- if(!$@ && $dbh)
+ if(!$@ && $dbh && $DBD::Pg::VERSION ge '2.15.1')
{
$Have{'pg'} = 1;
$Have{'pg_with_schema'} = 1;
Modified: trunk/librose-db-object-perl/t/db-object-helpers.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/t/db-object-helpers.t?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/t/db-object-helpers.t (original)
+++ trunk/librose-db-object-perl/t/db-object-helpers.t Fri Sep 25 18:06:24 2009
@@ -3,7 +3,7 @@
use strict;
#use Test::LongString;
-use Test::More tests => (90 * 4) + 3;
+use Test::More tests => (91 * 4) + 3;
BEGIN
{
@@ -27,7 +27,7 @@
{
SKIP:
{
- skip("$db_type tests", 90) unless($Have{$db_type});
+ skip("$db_type tests", 91) unless($Have{$db_type});
}
next unless($Have{$db_type});
@@ -290,12 +290,18 @@
{
$o = $class->new(id => 1)->load_or_save;
- my $frozen = Storable::freeze($o->strip);
+ # Confirm stripping of "on-save" code references
+ $o->rose_db_object_test_other({ name => 'test' });
+
+ eval { $o->strip };
+ like($@, qr/Refusing to strip "on-save" actions from \w+ object without strip_on_save_ok parameter/, "strip 1 - $db_type");
+
+ my $frozen = Storable::freeze($o->strip(strip_on_save_ok => 1));
my $thawed = Storable::thaw($frozen);
- is_deeply($thawed, $o, "strip 1 - $db_type");
- }
- else { SKIP: { skip("tests that require Storable - $db_type", 1) } }
+ is_deeply($thawed, $o, "strip 2 - $db_type");
+ }
+ else { SKIP: { skip("tests that require Storable - $db_type", 2) } }
$o = $class->new(id => 1, name => 'John', age => 30)->load_or_save;
Modified: trunk/librose-db-object-perl/t/db-object-manager.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/t/db-object-manager.t?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/t/db-object-manager.t (original)
+++ trunk/librose-db-object-perl/t/db-object-manager.t Fri Sep 25 18:06:24 2009
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 3903;
+use Test::More tests => 3904;
BEGIN
{
@@ -125,6 +125,22 @@
[
id => { ge => 1 },
id => [ \'1', \'id' ], #'
+ id => { gt_lt => [ -1, 991 ] },
+ id => { gt_le => [ -1, 992 ] },
+ id => { ge_lt => [ -1, 993 ] },
+ id => { ge_le => [ -1, 994 ] },
+ id => { gt_lt_sql => [ -1, 991 ] },
+ id => { gt_le_sql => [ -1, 992 ] },
+ id => { ge_lt_sql => [ -1, 993 ] },
+ id => { ge_le_sql => [ -1, 994 ] },
+ id => { gt_lt => [ -1, \991 ] },
+ id => { gt_le => [ \-1, 992 ] },
+ id => { ge_lt => [ -1, \993 ] },
+ id => { ge_le => [ \-1, 994 ] },
+ id => { between => [ 0, 99 ] },
+ id => { between => [ 0, \q(101) ] },
+ id => { between => [ \1, 99 ] },
+ id => { ne => undef },
name => 'John',
flag => 't',
flag2 => 'f',
@@ -138,6 +154,9 @@
or => [ and => [ '!bits' => '00001', bits => { ne => '11111' } ],
and => [ bits => { lt => '10101' }, '!bits' => '10000' ] ],
start => '2001-01-02',
+ start => { lt => \q('now'::date + interval '30 days') },
+ start => { between => [ '1/1/1999', 'now' ] },
+ start => { between_sql => [ "'1999-02-02'", "'now'" ] },
save => [ 1, 5 ],
nums => '{1,2,3}',
fk1 => 2,
@@ -3030,6 +3049,23 @@
query =>
[
id => { ge => 1 },
+ id => { ge => 1 },
+ id => [ \'1', \'id' ], #'
+ id => { gt_lt => [ -1, 991 ] },
+ id => { gt_le => [ -1, 992 ] },
+ id => { ge_lt => [ -1, 993 ] },
+ id => { ge_le => [ -1, 994 ] },
+ id => { gt_lt_sql => [ -1, 991 ] },
+ id => { gt_le_sql => [ -1, 992 ] },
+ id => { ge_lt_sql => [ -1, 993 ] },
+ id => { ge_le_sql => [ -1, 994 ] },
+ id => { gt_lt => [ -1, \991 ] },
+ id => { gt_le => [ \-1, 992 ] },
+ id => { ge_lt => [ -1, \993 ] },
+ id => { ge_le => [ \-1, 994 ] },
+ id => { between => [ 0, 99 ] },
+ id => { between => [ 0, \q(101) ] },
+ id => { between => [ \1, 99 ] },
name => 'John',
flag => 1,
flag2 => 0,
@@ -3062,6 +3098,9 @@
or => [ and => [ '!bits' => '00001', bits => { ne => '11111' } ],
and => [ bits => { lt => '10101' }, '!bits' => '10000' ] ],
start => '2001-01-02',
+ start => { le => \q(NOW()) },
+ start => { between => [ '1/1/1999', 'NOW()' ] },
+ start => { between_sql => [ "'1999-02-02'", 'NOW()' ] },
save_col => [ 1, 5 ],
last_modified => { le => 'now' },
date_created => '2004-03-30 12:34:56',
@@ -8683,16 +8722,21 @@
SKIP: foreach my $db_type (qw(sqlite))
{
- skip("SQLite tests", 791) unless($HAVE_SQLITE);
+ skip("SQLite tests", 792) unless($HAVE_SQLITE);
Rose::DB->default_type($db_type);
my($sql, $bind) =
Rose::DB::Object::Manager->get_objects_sql(
object_class => 'MySQLiteObject',
- where => [ name => { '@' => \q(xxx) } ]);
-
- ok($sql =~ /\bname @ xxx\b/, "strict_ops 1 - $db_type");
+ where =>
+ [
+ name => { '@' => \q(xxx) },
+ start => { lt => \q(CURRENT_TIMESTAMP) },
+ ]);
+
+ like($sql, qr/\bname @ xxx\b/, "strict_ops 1.0 - $db_type");
+ like($sql, qr/\bstart < CURRENT_TIMESTAMP\b/, "strict_ops 1.1 - $db_type");
eval
{
@@ -8786,6 +8830,21 @@
#debug => 1,
query =>
[
+ id => { gt_lt => [ -1, 991 ] },
+ id => { gt_le => [ -1, 992 ] },
+ id => { ge_lt => [ -1, 993 ] },
+ id => { ge_le => [ -1, 994 ] },
+ id => { gt_lt_sql => [ -1, 991 ] },
+ id => { gt_le_sql => [ -1, 992 ] },
+ id => { ge_lt_sql => [ -1, 993 ] },
+ id => { ge_le_sql => [ -1, 994 ] },
+ id => { gt_lt => [ -1, \991 ] },
+ id => { gt_le => [ \-1, 992 ] },
+ id => { ge_lt => [ -1, \993 ] },
+ id => { ge_le => [ \-1, 994 ] },
+ id => { between => [ 0, 99 ] },
+ id => { between => [ 0, \q(101) ] },
+ id => { between => [ \1, 99 ] },
id => { ge => 1 },
id => { ne => undef },
fk3 => { eq => undef },
@@ -8795,6 +8854,9 @@
flag2 => 0,
\q((1 = 1 and 5 > 2)),
[ \q(fk1 > ?), 1 ],
+ start => { le => \q(CURRENT_TIMESTAMP) },
+ start => { between => [ '1/1/1999', 'CURRENT_TIMESTAMP' ] },
+ start => { between_sql => [ "'1999-02-02'", 'CURRENT_TIMESTAMP' ] },
or =>
[
bits => '00001',
Modified: trunk/librose-db-object-perl/t/db-object.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/librose-db-object-perl/t/db-object.t?rev=44823&op=diff
==============================================================================
--- trunk/librose-db-object-perl/t/db-object.t (original)
+++ trunk/librose-db-object-perl/t/db-object.t Fri Sep 25 18:06:24 2009
@@ -2126,7 +2126,6 @@
MyOracleObject->meta->column('k1')->primary_key_position(7);
Test::More::ok(!defined MyOracleObject->meta->column('k1')->primary_key_position, 'primary_key_position 3 - oracle');
}
-
}
END
More information about the Pkg-perl-cvs-commits
mailing list