From 5c33eece17f5293f8ae79341c4a59f9f53f389ab Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Sun, 7 Sep 2025 21:00:15 +0900 Subject: [PATCH 01/26] accept prepared statement in terms array --- lib/Data/ObjectDriver/SQL.pm | 3 + t/11-sql-with-models.t | 107 +++++++++++++++++++++++++++++++++++ 2 files changed, 110 insertions(+) create mode 100644 t/11-sql-with-models.t diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index 8c43856..1d34581 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -283,6 +283,9 @@ sub _mk_term { } else { if (ref $val->{value} eq 'SCALAR') { $term = "$c $val->{op} " . ${$val->{value}}; + } elsif (UNIVERSAL::isa( $val->{value}, "Data::ObjectDriver::SQL" )) { + $term = "$c $val->{op} (". $val->{value}->as_sql. ')'; + push @bind, @{$val->{value}->{bind}}; } else { $term = "$c $val->{op} ?"; $term .= $stmt->as_escape($val->{escape}) if $val->{escape} && $op =~ /^(?:NOT\s+)?I?LIKE$/; diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t new file mode 100644 index 0000000..11b3d54 --- /dev/null +++ b/t/11-sql-with-models.t @@ -0,0 +1,107 @@ +# $Id$ + +use strict; +use warnings; + +use lib 't/lib'; +use lib 't/lib/cached'; +use Data::ObjectDriver::SQL; +use Test::More tests => 1; +use DodTestUtil; + +BEGIN { DodTestUtil->check_driver } + +subtest 'reuse prepared statement(complex)' => sub { + require Recipe; + require Ingredient; + + subtest 'case1' => sub { + my $stmt = Recipe->driver->prepare_statement( + 'Recipe', [ + { title => 'title1' }, + { + recipe_id => { + op => 'IN', + value => Ingredient->driver->prepare_statement( + 'Ingredient', + { col1 => { op => 'LIKE', value => 'sub1', escape => '!' } }, + { fetchonly => ['id'], limit => 2 }) } + }, + ], + { limit => 4 }); + + my $expected = sql_normalize(<<'EOF'); +SELECT + recipes.recipe_id, recipes.title +FROM + recipes +WHERE + ((title = ?)) + AND + ((recipe_id IN (SELECT ingredients.id FROM ingredients WHERE (ingredients.col1 LIKE ? ESCAPE '!') LIMIT 2))) +LIMIT 4 +EOF + is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; + is_deeply($stmt->{bind}, ['title1', 'sub1'], 'right bind values'); + }; + + subtest 'case2' => sub { + my $stmt = Recipe->driver->prepare_statement( + 'Recipe', + [[ + { title => 'title1' }, + '-or', + { + recipe_id => { + op => 'IN', + value => Ingredient->driver->prepare_statement( + 'Ingredient', [ + { col1 => { op => 'LIKE', value => 'sub1', escape => '!' } }, + { col2 => { op => 'LIKE', value => 'sub2', escape => '!' } }, + ], + { fetchonly => ['id'], limit => 2 }) } + }, + '-or', + { title => 'title2' }, + ], + { title3 => 'title3' }, + ], + { limit => 4 }); + + my $expected = sql_normalize(<<'EOF'); +SELECT + recipes.recipe_id, recipes.title +FROM + recipes +WHERE + ( + ((title = ?)) + OR + ((recipe_id IN ( + SELECT ingredients.id + FROM ingredients + WHERE ((col1 LIKE ? ESCAPE '!')) AND ((col2 LIKE ? ESCAPE '!')) + LIMIT 2 + ))) + OR + ((title = ?)) + ) AND ( + (title3 = ?) + ) +LIMIT 4 +EOF + is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; + is_deeply($stmt->{bind}, ['title1', 'sub1', 'sub2', 'title2', 'title3'], 'right bind values'); + }; +}; + +sub sql_normalize { + my $sql = shift; + $sql =~ s{\s+}{ }g; + $sql =~ s{\( }{(}g; + $sql =~ s{ \)}{)}g; + $sql =~ s{([\(\)]) ([\(\)])}{$1$2}g; + $sql; +} + +sub ns { Data::ObjectDriver::SQL->new } From 445454d23ed500d7f62b740868d0b87eaf0d3d80 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Wed, 10 Sep 2025 16:33:00 +0900 Subject: [PATCH 02/26] accept prepared statement in select list --- lib/Data/ObjectDriver/SQL.pm | 42 ++++++++++++++------ t/11-sql-with-models.t | 74 ++++++++++++++++++++++++++++++++++-- 2 files changed, 101 insertions(+), 15 deletions(-) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index 1d34581..67c86b0 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -3,6 +3,7 @@ package Data::ObjectDriver::SQL; use strict; use warnings; +use Scalar::Util 'blessed'; use base qw( Class::Accessor::Fast ); @@ -10,7 +11,7 @@ __PACKAGE__->mk_accessors(qw( select distinct select_map select_map_reverse from joins where bind limit offset group order having where_values column_mutator index_hint - comment + comment as )); sub new { @@ -35,8 +36,10 @@ sub add_select { my($term, $col) = @_; $col ||= $term; push @{ $stmt->select }, $term; - $stmt->select_map->{$term} = $col; - $stmt->select_map_reverse->{$col} = $term; + if (!blessed($term)) { + $stmt->select_map->{$term} = $col; + $stmt->select_map_reverse->{$col} = $term; + } } sub add_join { @@ -64,8 +67,15 @@ sub as_sql { $sql .= 'SELECT '; $sql .= 'DISTINCT ' if $stmt->distinct; $sql .= join(', ', map { - my $alias = $stmt->select_map->{$_}; - $alias && /(?:^|\.)\Q$alias\E$/ ? $_ : "$_ $alias"; + my $col = $_; + if (blessed($col) && $col->isa('Data::ObjectDriver::SQL')) { + my $sub_sql = $col->as_subquery; + push @{$stmt->{bind}}, @{$col->{bind}}; + $sub_sql; + } else { + my $alias = $stmt->select_map->{$_}; + $alias && /(?:^|\.)\Q$alias\E$/ ? $_ : "$_ $alias"; + } } @{ $stmt->select }) . "\n"; } $sql .= 'FROM '; @@ -110,6 +120,15 @@ sub as_sql { return $sql; } +sub as_subquery { + my $stmt = shift; + my $subquery = '('. $stmt->as_sql. ')'; + if ($stmt->as) { + $subquery .= ' AS ' . $stmt->as; + } + $subquery; +} + sub as_limit { my $stmt = shift; my $n = $stmt->limit or @@ -281,15 +300,16 @@ sub _mk_term { $term = "$c $op ? AND ?"; push @bind, @{$val->{value}}; } else { - if (ref $val->{value} eq 'SCALAR') { - $term = "$c $val->{op} " . ${$val->{value}}; - } elsif (UNIVERSAL::isa( $val->{value}, "Data::ObjectDriver::SQL" )) { - $term = "$c $val->{op} (". $val->{value}->as_sql. ')'; - push @bind, @{$val->{value}->{bind}}; + my $value = $val->{value}; + if (ref $value eq 'SCALAR') { + $term = "$c $val->{op} " . $$value; + } elsif (blessed($value) && $value->isa('Data::ObjectDriver::SQL')) { + $term = "$c $val->{op} ". $value->as_subquery; + push @bind, @{$value->{bind}}; } else { $term = "$c $val->{op} ?"; $term .= $stmt->as_escape($val->{escape}) if $val->{escape} && $op =~ /^(?:NOT\s+)?I?LIKE$/; - push @bind, $val->{value}; + push @bind, $value; } } } elsif (ref($val) eq 'SCALAR') { diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 11b3d54..6be7d25 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -6,14 +6,79 @@ use warnings; use lib 't/lib'; use lib 't/lib/cached'; use Data::ObjectDriver::SQL; -use Test::More tests => 1; +use Test::More tests => 3; use DodTestUtil; +use Recipe; +use Ingredient; BEGIN { DodTestUtil->check_driver } -subtest 'reuse prepared statement(complex)' => sub { - require Recipe; - require Ingredient; +subtest 'as_subquery' => sub { + my $stmt = Ingredient->driver->prepare_statement('Ingredient', { col1 => 'sub1' }, { fetchonly => ['id'] }); + + is(sql_normalize($stmt->as_subquery), sql_normalize(<<'EOF'), 'right sql'); +(SELECT ingredients.id FROM ingredients WHERE (ingredients.col1 = ?)) +EOF + is_deeply($stmt->{bind}, ['sub1'], 'right bind values'); + + $stmt->as('mysubquery'); + + is(sql_normalize($stmt->as_subquery), sql_normalize(<<'EOF'), 'right sql'); +(SELECT ingredients.id FROM ingredients WHERE (ingredients.col1 = ?)) AS mysubquery +EOF +}; + +subtest 'subquery in select clause' => sub { + + subtest 'case1' => sub { + my $stmt = Recipe->driver->prepare_statement('Recipe', [{ title => 'title1' }, {}], {}); + $stmt->add_select(Ingredient->driver->prepare_statement( + 'Ingredient', + [{ recipe_id => \'= recipes.recipe_id' }, { col1 => 'sub1' }], { fetchonly => ['id'] })); + + my $expected = sql_normalize(<<'EOF'); +SELECT + recipes.recipe_id, + recipes.title, + ( + SELECT ingredients.id + FROM ingredients + WHERE ((recipe_id = recipes.recipe_id)) AND ((col1 = ?)) + ) +FROM recipes +WHERE ((title = ?)) +EOF + + is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; + is_deeply($stmt->{bind}, ['title1', 'sub1'], 'right bind values'); + }; + + subtest 'with alias' => sub { + my $stmt = Recipe->driver->prepare_statement('Recipe', [{}, {}], {}); + my $subquery = Ingredient->driver->prepare_statement( + 'Ingredient', + [{ recipe_id => \'= recipes.recipe_id' }], { fetchonly => ['id'] }); + $subquery->as('sub_alias'); + $stmt->add_select($subquery); + + my $expected = sql_normalize(<<'EOF'); +SELECT + recipes.recipe_id, + recipes.title, + ( + SELECT ingredients.id + FROM ingredients + WHERE ((recipe_id = recipes.recipe_id)) + ) AS sub_alias +FROM recipes +EOF + + is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; + is_deeply($stmt->{bind}, [], 'right bind values'); + }; +}; + +subtest 'subquery in where clause' => sub { subtest 'case1' => sub { my $stmt = Recipe->driver->prepare_statement( @@ -98,6 +163,7 @@ EOF sub sql_normalize { my $sql = shift; $sql =~ s{\s+}{ }g; + $sql =~ s{ $}{}g; $sql =~ s{\( }{(}g; $sql =~ s{ \)}{)}g; $sql =~ s{([\(\)]) ([\(\)])}{$1$2}g; From f5464a761bc5bb25e01cef72a37dc27f225b9b7c Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Wed, 10 Sep 2025 16:47:55 +0900 Subject: [PATCH 03/26] use models after check_driver --- t/11-sql-with-models.t | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 6be7d25..053190f 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -8,11 +8,12 @@ use lib 't/lib/cached'; use Data::ObjectDriver::SQL; use Test::More tests => 3; use DodTestUtil; -use Recipe; -use Ingredient; BEGIN { DodTestUtil->check_driver } +use Recipe; +use Ingredient; + subtest 'as_subquery' => sub { my $stmt = Ingredient->driver->prepare_statement('Ingredient', { col1 => 'sub1' }, { fetchonly => ['id'] }); From f7bd7d4c190281b6cc4354bf5b58de6c5bb7d983 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 11 Sep 2025 01:26:15 +0900 Subject: [PATCH 04/26] accept prepared statement in from clause --- lib/Data/ObjectDriver/SQL.pm | 22 +++++++-- t/11-sql-with-models.t | 87 +++++++++++++++++++++++++++++++++--- 2 files changed, 100 insertions(+), 9 deletions(-) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index 67c86b0..10c4917 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -63,15 +63,16 @@ sub add_index_hint { sub as_sql { my $stmt = shift; my $sql = ''; + my @bind_for_select; + if (@{ $stmt->select }) { $sql .= 'SELECT '; $sql .= 'DISTINCT ' if $stmt->distinct; $sql .= join(', ', map { my $col = $_; if (blessed($col) && $col->isa('Data::ObjectDriver::SQL')) { - my $sub_sql = $col->as_subquery; - push @{$stmt->{bind}}, @{$col->{bind}}; - $sub_sql; + push @bind_for_select, @{ $col->{bind} }; + $col->as_subquery; } else { my $alias = $stmt->select_map->{$_}; $alias && /(?:^|\.)\Q$alias\E$/ ? $_ : "$_ $alias"; @@ -101,8 +102,18 @@ sub as_sql { $sql .= ', ' if @from; } + my @bind_for_from; + if (@from) { - $sql .= join ', ', map { $stmt->_add_index_hint($_) } @from; + $sql .= join ', ', map { + my $from = $_; + if (blessed($from) && $from->isa('Data::ObjectDriver::SQL')) { + push @bind_for_from, @{$from->{bind}}; + $from->as_subquery; + } else { + $stmt->_add_index_hint($from); + } + } @from; } $sql .= "\n"; @@ -117,6 +128,9 @@ sub as_sql { if ($comment && $comment =~ /([ 0-9a-zA-Z.:;()_#&,]+)/) { $sql .= "-- $1" if $1; } + + @{ $stmt->{bind} } = (@bind_for_select, @bind_for_from, @{ $stmt->{bind} }); + return $sql; } diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 053190f..d802f4f 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -6,7 +6,7 @@ use warnings; use lib 't/lib'; use lib 't/lib/cached'; use Data::ObjectDriver::SQL; -use Test::More tests => 3; +use Test::More tests => 5; use DodTestUtil; BEGIN { DodTestUtil->check_driver } @@ -51,11 +51,11 @@ WHERE ((title = ?)) EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; - is_deeply($stmt->{bind}, ['title1', 'sub1'], 'right bind values'); + is_deeply($stmt->{bind}, ['sub1', 'title1'], 'right bind values'); }; subtest 'with alias' => sub { - my $stmt = Recipe->driver->prepare_statement('Recipe', [{}, {}], {}); + my $stmt = Recipe->driver->prepare_statement('Recipe', [{}, {}], {}); my $subquery = Ingredient->driver->prepare_statement( 'Ingredient', [{ recipe_id => \'= recipes.recipe_id' }], { fetchonly => ['id'] }); @@ -79,6 +79,57 @@ EOF }; }; +subtest 'subquery in from clause' => sub { + + subtest 'case1' => sub { + my $stmt = Recipe->driver->prepare_statement('Recipe', [{ title => 'title1' }, {}], {}); + my $subquery = Ingredient->driver->prepare_statement( + 'Ingredient', + [{ recipe_id => \'= recipes.recipe_id' }, { col1 => 'sub1' }], { fetchonly => ['id'] }); + push @{ $stmt->from }, $subquery; + + my $expected = sql_normalize(<<'EOF'); +SELECT + recipes.recipe_id, + recipes.title +FROM recipes, + ( + SELECT ingredients.id + FROM ingredients + WHERE ((recipe_id = recipes.recipe_id)) AND ((col1 = ?)) + ) +WHERE ((title = ?)) +EOF + + is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; + is_deeply($stmt->{bind}, ['sub1', 'title1'], 'right bind values'); + }; + + subtest 'with alias' => sub { + my $stmt = Recipe->driver->prepare_statement('Recipe', [{}, {}], {}); + my $subquery = Ingredient->driver->prepare_statement( + 'Ingredient', + [{ recipe_id => \'= recipes.recipe_id' }], { fetchonly => ['id'] }); + $subquery->as('sub_alias'); + push @{ $stmt->from }, $subquery; + + my $expected = sql_normalize(<<'EOF'); +SELECT + recipes.recipe_id, + recipes.title +FROM recipes, + ( + SELECT ingredients.id + FROM ingredients + WHERE ((recipe_id = recipes.recipe_id)) + ) AS sub_alias +EOF + + is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; + is_deeply($stmt->{bind}, [], 'right bind values'); + }; +}; + subtest 'subquery in where clause' => sub { subtest 'case1' => sub { @@ -89,8 +140,8 @@ subtest 'subquery in where clause' => sub { recipe_id => { op => 'IN', value => Ingredient->driver->prepare_statement( - 'Ingredient', - { col1 => { op => 'LIKE', value => 'sub1', escape => '!' } }, + 'Ingredient', + { col1 => { op => 'LIKE', value => 'sub1', escape => '!' } }, { fetchonly => ['id'], limit => 2 }) } }, ], @@ -161,6 +212,32 @@ EOF }; }; +subtest 'subquery in multiple clauses' => sub { + my $sub1 = Ingredient->driver->prepare_statement('Ingredient', { id => 1 }, { fetchonly => ['id'] }); + my $sub2 = Ingredient->driver->prepare_statement('Ingredient', { id => 2 }, { fetchonly => ['id'] }); + my $sub3 = Ingredient->driver->prepare_statement('Ingredient', { id => 3 }, { fetchonly => ['id'] }); + $sub1->as('sub1'); + $sub2->as('sub2'); + $sub3->as('sub3'); + my $stmt = Recipe->driver->prepare_statement('Recipe', { recipe_id => { op => '=', value => $sub3 } }, {}); + $stmt->add_select($sub1); + push @{ $stmt->from }, $sub2; + + my $expected = sql_normalize(<<'EOF'); +SELECT + recipes.recipe_id, + recipes.title, + (SELECT ingredients.id FROM ingredients WHERE (ingredients.id = ?)) AS sub1 +FROM + recipes, + (SELECT ingredients.id FROM ingredients WHERE (ingredients.id = ?)) AS sub2 +WHERE + (recipes.recipe_id = (SELECT ingredients.id FROM ingredients WHERE (ingredients.id = ?)) AS sub3) +EOF + is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; + is_deeply($stmt->{bind}, ['1', '2', '3'], 'right bind values'); +}; + sub sql_normalize { my $sql = shift; $sql =~ s{\s+}{ }g; From d2f906fb9e48ff7c8ceae98f0a4a68d2b2cfa284 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 11 Sep 2025 16:07:59 +0900 Subject: [PATCH 05/26] subquery alias should be set to select_map --- lib/Data/ObjectDriver/SQL.pm | 7 +++- t/11-sql-with-models.t | 66 ++++++++++++++++++++++++++++++++++-- t/11-sql.t | 39 +++++++++++++++------ 3 files changed, 99 insertions(+), 13 deletions(-) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index 10c4917..78ee8f3 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -36,7 +36,12 @@ sub add_select { my($term, $col) = @_; $col ||= $term; push @{ $stmt->select }, $term; - if (!blessed($term)) { + if (blessed($term) && $col->isa('Data::ObjectDriver::SQL')) { + if (my $alias = $term->as) { + $stmt->select_map->{$term} = $alias; + $stmt->select_map_reverse->{$col} = $term; + } + } else { $stmt->select_map->{$term} = $col; $stmt->select_map_reverse->{$col} = $term; } diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index d802f4f..338bc45 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -6,7 +6,7 @@ use warnings; use lib 't/lib'; use lib 't/lib/cached'; use Data::ObjectDriver::SQL; -use Test::More tests => 5; +use Test::More tests => 6; use DodTestUtil; BEGIN { DodTestUtil->check_driver } @@ -14,6 +14,10 @@ BEGIN { DodTestUtil->check_driver } use Recipe; use Ingredient; +setup_dbs({ + global => [ qw( recipes ingredients ) ], +}); + subtest 'as_subquery' => sub { my $stmt = Ingredient->driver->prepare_statement('Ingredient', { col1 => 'sub1' }, { fetchonly => ['id'] }); @@ -238,6 +242,61 @@ EOF is_deeply($stmt->{bind}, ['1', '2', '3'], 'right bind values'); }; +subtest 'subquery in select list actually works' => sub { + + require Data::ObjectDriver::Driver::DBI; + my $stmt; + my $sub_stmt; + my $prepare_statement_org = \&Data::ObjectDriver::Driver::DBI::prepare_statement; + local *Data::ObjectDriver::Driver::DBI::prepare_statement = sub { + $stmt = $prepare_statement_org->(@_); + $sub_stmt = $prepare_statement_org->( + Ingredient->driver, + 'Ingredient', + [{ 'ingredients.recipe_id' => \'= recipes.recipe_id' }], { fetchonly => ['name'] }); + $sub_stmt->as('ingredient_name'); + $stmt->add_select($sub_stmt); + return $stmt; + }; + + { + my $r = Recipe->new; + $r->title('MyRecipe1'); + $r->save; + my $i = Ingredient->new; + $i->recipe_id($r->recipe_id); + $i->name('salt'); + $i->save; + } + + my @recipes = eval { Recipe->search({}, {}) }; + note explain(@recipes); + + is sql_normalize($stmt->as_sql), sql_normalize(<<'EOF'), 'right sql'; +SELECT + recipes.recipe_id, + recipes.title, + ( + SELECT ingredients.name + FROM ingredients + WHERE ((ingredients.recipe_id = recipes.recipe_id)) + ) AS ingredient_name +FROM recipes +EOF + + is_deeply( + $stmt->select_map, { + 'recipes.recipe_id' => 'recipe_id', + 'recipes.title' => 'title', + "$sub_stmt" => 'ingredient_name', + }, + 'right select map' + ); + ok(!$@, 'no error') || warn $@; + is scalar(@recipes), 1, 'right number of results'; + is $recipes[0]{column_values}{ingredient_name}, 'salt', 'right ingredient_name'; # XXX is it expected? +}; + sub sql_normalize { my $sql = shift; $sql =~ s{\s+}{ }g; @@ -248,4 +307,7 @@ sub sql_normalize { $sql; } -sub ns { Data::ObjectDriver::SQL->new } +END { + disconnect_all(qw/Recipe Ingredient/); + teardown_dbs(qw( global )); +} diff --git a/t/11-sql.t b/t/11-sql.t index 56a21ad..160a23c 100644 --- a/t/11-sql.t +++ b/t/11-sql.t @@ -3,7 +3,7 @@ use strict; use Data::ObjectDriver::SQL; -use Test::More tests => 113; +use Test::More tests => 110; my $stmt = ns(); ok($stmt, 'Created SQL object'); @@ -284,15 +284,34 @@ $stmt->add_select('bar'); $stmt->from([ qw( baz ) ]); is($stmt->as_sql, "SELECT foo, bar\nFROM baz\n"); -$stmt = ns(); -$stmt->add_select('f.foo' => 'foo'); -$stmt->add_select('COUNT(*)' => 'count'); -$stmt->from([ qw( baz ) ]); -is($stmt->as_sql, "SELECT f.foo, COUNT(*) count\nFROM baz\n"); -my $map = $stmt->select_map; -is(scalar(keys %$map), 2); -is($map->{'f.foo'}, 'foo'); -is($map->{'COUNT(*)'}, 'count'); +subtest 'SQL functions' => sub { + $stmt = ns(); + $stmt->add_select('f.foo' => 'foo'); + $stmt->add_select('COUNT(*)' => 'count'); + $stmt->from([ qw( baz ) ]); + is($stmt->as_sql, "SELECT f.foo, COUNT(*) count\nFROM baz\n"); + my $map = $stmt->select_map; + is(scalar(keys %$map), 2); + is_deeply($map, {'f.foo' => 'foo', 'COUNT(*)' => 'count'}, 'right map'); + + $stmt = ns(); + $stmt->add_select('count(foo)'); + $stmt->add_select('count(bar)'); + $stmt->from([qw( baz )]); + is($stmt->as_sql, "SELECT count(foo), count(bar)\nFROM baz\n"); + my $map = $stmt->select_map; + is(scalar(keys %$map), 2); + is_deeply($map, {'count(foo)' => 'count(foo)', 'count(bar)' => 'count(bar)'}, 'right map'); + + $stmt = ns(); + $stmt->add_select('count(foo)', 'count1'); + $stmt->add_select('count(bar)', 'count2'); + $stmt->from([qw( baz )]); + is($stmt->as_sql, "SELECT count(foo) count1, count(bar) count2\nFROM baz\n"); + my $map = $stmt->select_map; + is(scalar(keys %$map), 2); + is_deeply($map, {'count(foo)' => 'count1', 'count(bar)' => 'count2'}, 'right map'); +}; # HAVING $stmt = ns(); From 8ff74a5ca1d203514879037adc8015e267aaf7e2 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 12 Sep 2025 02:59:28 +0900 Subject: [PATCH 06/26] select_map_reverse is not needed for subquery --- lib/Data/ObjectDriver/SQL.pm | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index 78ee8f3..e3548f7 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -39,7 +39,6 @@ sub add_select { if (blessed($term) && $col->isa('Data::ObjectDriver::SQL')) { if (my $alias = $term->as) { $stmt->select_map->{$term} = $alias; - $stmt->select_map_reverse->{$col} = $term; } } else { $stmt->select_map->{$term} = $col; From 2191c0d23d78cb07f9fbbd88fbd98e5dc53a0f2f Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 12 Sep 2025 03:59:13 +0900 Subject: [PATCH 07/26] set select_map for subquery without alias to silence uuv --- lib/Data/ObjectDriver/SQL.pm | 4 +- t/11-sql-with-models.t | 96 ++++++++++++++++++++++++++---------- 2 files changed, 70 insertions(+), 30 deletions(-) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index e3548f7..abb8078 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -37,9 +37,7 @@ sub add_select { $col ||= $term; push @{ $stmt->select }, $term; if (blessed($term) && $col->isa('Data::ObjectDriver::SQL')) { - if (my $alias = $term->as) { - $stmt->select_map->{$term} = $alias; - } + $stmt->select_map->{$term} = $term->as; } else { $stmt->select_map->{$term} = $col; $stmt->select_map_reverse->{$col} = $term; diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 338bc45..e222fc3 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -245,19 +245,7 @@ EOF subtest 'subquery in select list actually works' => sub { require Data::ObjectDriver::Driver::DBI; - my $stmt; - my $sub_stmt; my $prepare_statement_org = \&Data::ObjectDriver::Driver::DBI::prepare_statement; - local *Data::ObjectDriver::Driver::DBI::prepare_statement = sub { - $stmt = $prepare_statement_org->(@_); - $sub_stmt = $prepare_statement_org->( - Ingredient->driver, - 'Ingredient', - [{ 'ingredients.recipe_id' => \'= recipes.recipe_id' }], { fetchonly => ['name'] }); - $sub_stmt->as('ingredient_name'); - $stmt->add_select($sub_stmt); - return $stmt; - }; { my $r = Recipe->new; @@ -269,10 +257,23 @@ subtest 'subquery in select list actually works' => sub { $i->save; } - my @recipes = eval { Recipe->search({}, {}) }; - note explain(@recipes); - - is sql_normalize($stmt->as_sql), sql_normalize(<<'EOF'), 'right sql'; + subtest 'case1' => sub { + my $stmt; + my $sub_stmt; + local *Data::ObjectDriver::Driver::DBI::prepare_statement = sub { + $stmt = $prepare_statement_org->(@_); + $sub_stmt = $prepare_statement_org->( + Ingredient->driver, + 'Ingredient', + [{ 'ingredients.recipe_id' => \'= recipes.recipe_id' }], { fetchonly => ['name'] }); + $sub_stmt->as('ingredient_name'); + $stmt->add_select($sub_stmt); + return $stmt; + }; + + my @recipes = eval { Recipe->search({}, {}) }; + + is sql_normalize($stmt->as_sql), sql_normalize(<<'EOF'), 'right sql'; SELECT recipes.recipe_id, recipes.title, @@ -284,17 +285,58 @@ SELECT FROM recipes EOF - is_deeply( - $stmt->select_map, { - 'recipes.recipe_id' => 'recipe_id', - 'recipes.title' => 'title', - "$sub_stmt" => 'ingredient_name', - }, - 'right select map' - ); - ok(!$@, 'no error') || warn $@; - is scalar(@recipes), 1, 'right number of results'; - is $recipes[0]{column_values}{ingredient_name}, 'salt', 'right ingredient_name'; # XXX is it expected? + is_deeply( + $stmt->select_map, { + 'recipes.recipe_id' => 'recipe_id', + 'recipes.title' => 'title', + "$sub_stmt" => 'ingredient_name', + }, + 'right select map' + ); + ok(!$@, 'no error') || note $@; + is scalar(@recipes), 1, 'right number of results'; + is $recipes[0]{column_values}{ingredient_name}, 'salt', 'right ingredient_name'; # XXX is it expected? + }; + + subtest 'without alias' => sub { + my $stmt; + my $sub_stmt; + local *Data::ObjectDriver::Driver::DBI::prepare_statement = sub { + $stmt = $prepare_statement_org->(@_); + $sub_stmt = $prepare_statement_org->( + Ingredient->driver, + 'Ingredient', + [{ 'ingredients.recipe_id' => \'= recipes.recipe_id' }], { fetchonly => ['name'] }); + $stmt->add_select($sub_stmt); + return $stmt; + }; + + my @recipes = eval { Recipe->search({}, {}) }; + + is sql_normalize($stmt->as_sql), sql_normalize(<<'EOF'), 'right sql'; +SELECT + recipes.recipe_id, + recipes.title, + ( + SELECT ingredients.name + FROM ingredients + WHERE ((ingredients.recipe_id = recipes.recipe_id)) + ) +FROM recipes +EOF + + is_deeply( + $stmt->select_map, { + 'recipes.recipe_id' => 'recipe_id', + 'recipes.title' => 'title', + "$sub_stmt" => undef, + }, + 'right select map' + ); + ok(!$@, 'no error') || note $@; + is scalar(@recipes), 1, 'right number of results'; + is $recipes[0]{column_values}{''}, 'salt', 'right ingredient_name'; # XXX is it expected? + }; }; sub sql_normalize { From b47fb2f7cc92253d82b748e29971df47731e88a2 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 12 Sep 2025 08:10:08 +0900 Subject: [PATCH 08/26] fix uuv again --- lib/Data/ObjectDriver/Driver/DBI.pm | 2 +- t/11-sql-with-models.t | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Data/ObjectDriver/Driver/DBI.pm b/lib/Data/ObjectDriver/Driver/DBI.pm index 148db0d..d51cc8e 100644 --- a/lib/Data/ObjectDriver/Driver/DBI.pm +++ b/lib/Data/ObjectDriver/Driver/DBI.pm @@ -184,7 +184,7 @@ sub fetch { my @bind; my $map = $stmt->select_map; for my $col (@{ $stmt->select }) { - push @bind, \$rec->{ $map->{$col} }; + push @bind, \$rec->{ $map->{$col} || $col }; } my $dbh = $driver->r_handle($class->properties->{db}); diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index e222fc3..f0fb7d4 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -334,8 +334,8 @@ EOF 'right select map' ); ok(!$@, 'no error') || note $@; - is scalar(@recipes), 1, 'right number of results'; - is $recipes[0]{column_values}{''}, 'salt', 'right ingredient_name'; # XXX is it expected? + is scalar(@recipes), 1, 'right number of results'; + is $recipes[0]{column_values}{"$sub_stmt"}, 'salt', 'right ingredient_name'; # XXX is it expected? }; }; From f1688e1599868c360227924630a6b5b09bd4c9ee Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Tue, 16 Sep 2025 14:25:50 +0900 Subject: [PATCH 09/26] cleanup test --- t/11-sql-with-models.t | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index f0fb7d4..739ae9a 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -36,7 +36,7 @@ EOF subtest 'subquery in select clause' => sub { subtest 'case1' => sub { - my $stmt = Recipe->driver->prepare_statement('Recipe', [{ title => 'title1' }, {}], {}); + my $stmt = Recipe->driver->prepare_statement('Recipe', [{ title => 'title1' }], {}); $stmt->add_select(Ingredient->driver->prepare_statement( 'Ingredient', [{ recipe_id => \'= recipes.recipe_id' }, { col1 => 'sub1' }], { fetchonly => ['id'] })); @@ -59,7 +59,7 @@ EOF }; subtest 'with alias' => sub { - my $stmt = Recipe->driver->prepare_statement('Recipe', [{}, {}], {}); + my $stmt = Recipe->driver->prepare_statement('Recipe', [], {}); my $subquery = Ingredient->driver->prepare_statement( 'Ingredient', [{ recipe_id => \'= recipes.recipe_id' }], { fetchonly => ['id'] }); @@ -86,7 +86,7 @@ EOF subtest 'subquery in from clause' => sub { subtest 'case1' => sub { - my $stmt = Recipe->driver->prepare_statement('Recipe', [{ title => 'title1' }, {}], {}); + my $stmt = Recipe->driver->prepare_statement('Recipe', [{ title => 'title1' }], {}); my $subquery = Ingredient->driver->prepare_statement( 'Ingredient', [{ recipe_id => \'= recipes.recipe_id' }, { col1 => 'sub1' }], { fetchonly => ['id'] }); @@ -110,7 +110,7 @@ EOF }; subtest 'with alias' => sub { - my $stmt = Recipe->driver->prepare_statement('Recipe', [{}, {}], {}); + my $stmt = Recipe->driver->prepare_statement('Recipe', [], {}); my $subquery = Ingredient->driver->prepare_statement( 'Ingredient', [{ recipe_id => \'= recipes.recipe_id' }], { fetchonly => ['id'] }); From cbadb9c1f060a88d55b13f5d60c51594faed7ace Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 18 Sep 2025 17:32:01 +0900 Subject: [PATCH 10/26] silence uuv --- lib/Data/ObjectDriver/SQL.pm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index abb8078..6b6a165 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -76,8 +76,11 @@ sub as_sql { push @bind_for_select, @{ $col->{bind} }; $col->as_subquery; } else { - my $alias = $stmt->select_map->{$_}; - $alias && /(?:^|\.)\Q$alias\E$/ ? $_ : "$_ $alias"; + if (my $alias = $stmt->select_map->{$col}) { + /(?:^|\.)\Q$alias\E$/ ? $col : "$col $alias"; + } else { + $col; + } } } @{ $stmt->select }) . "\n"; } From e031cfb7dc498a07a710bb1f0bfb596176dddef3 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 18 Sep 2025 17:34:55 +0900 Subject: [PATCH 11/26] do not aggricate bind array twice --- lib/Data/ObjectDriver/SQL.pm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index 6b6a165..2e2277b 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -11,7 +11,7 @@ __PACKAGE__->mk_accessors(qw( select distinct select_map select_map_reverse from joins where bind limit offset group order having where_values column_mutator index_hint - comment as + comment as aggrigated )); sub new { @@ -134,7 +134,10 @@ sub as_sql { $sql .= "-- $1" if $1; } - @{ $stmt->{bind} } = (@bind_for_select, @bind_for_from, @{ $stmt->{bind} }); + unless ($stmt->aggrigated) { + @{ $stmt->{bind} } = (@bind_for_select, @bind_for_from, @{ $stmt->{bind} }); + $stmt->aggrigated(1); + } return $sql; } From 9780fed7742b5bc9d3084e05a41206da8f733218 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 18 Sep 2025 22:16:54 +0900 Subject: [PATCH 12/26] subquery in select list must have an alias for later access --- lib/Data/ObjectDriver/SQL.pm | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index 2e2277b..ebd76b3 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -37,6 +37,7 @@ sub add_select { $col ||= $term; push @{ $stmt->select }, $term; if (blessed($term) && $col->isa('Data::ObjectDriver::SQL')) { + die 'Sub-query requires an alias by setting $stmt->as(...)' unless $term->as; $stmt->select_map->{$term} = $term->as; } else { $stmt->select_map->{$term} = $col; From e85a91392840da857b432ef443543f4c0c560925 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 18 Sep 2025 22:21:59 +0900 Subject: [PATCH 13/26] temporally remove subquery alias for WHERE, so the query may be reusable --- lib/Data/ObjectDriver/SQL.pm | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index ebd76b3..5464ea6 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -327,6 +327,7 @@ sub _mk_term { if (ref $value eq 'SCALAR') { $term = "$c $val->{op} " . $$value; } elsif (blessed($value) && $value->isa('Data::ObjectDriver::SQL')) { + local $value->{as} = undef; $term = "$c $val->{op} ". $value->as_subquery; push @bind, @{$value->{bind}}; } else { From 71ad5e20d608557ebdb8b4d515aabeedb939b597 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 18 Sep 2025 23:11:08 +0900 Subject: [PATCH 14/26] test that SQL actually works with DBI --- t/11-sql-with-models.t | 443 ++++++++++++++-------------- t/lib/Clone/PP.pm | 193 ++++++++++++ t/lib/Tie/IxHash.pm | 651 +++++++++++++++++++++++++++++++++++++++++ t/lib/sql/Blog.pm | 17 ++ t/lib/sql/Entry.pm | 17 ++ t/schemas/blog.sql | 5 + t/schemas/entry.sql | 6 + 7 files changed, 1118 insertions(+), 214 deletions(-) create mode 100644 t/lib/Clone/PP.pm create mode 100644 t/lib/Tie/IxHash.pm create mode 100644 t/lib/sql/Blog.pm create mode 100644 t/lib/sql/Entry.pm create mode 100644 t/schemas/blog.sql create mode 100644 t/schemas/entry.sql diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 739ae9a..921d3b2 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -4,340 +4,355 @@ use strict; use warnings; use lib 't/lib'; -use lib 't/lib/cached'; -use Data::ObjectDriver::SQL; +use lib 't/lib/sql'; use Test::More tests => 6; use DodTestUtil; +use Blog; +use Entry; +use Tie::IxHash; BEGIN { DodTestUtil->check_driver } -use Recipe; -use Ingredient; +sub ordered_hashref { + tie my %params, Tie::IxHash::, @_; + return \%params; +} setup_dbs({ - global => [ qw( recipes ingredients ) ], + global => [qw( blog entry )], }); +my $blog1 = Blog->new(name => 'blog1'); +$blog1->save; +my $blog2 = Blog->new(parent_id => $blog1->id, name => 'blog2'); +$blog2->save; +my $entry11 = Entry->new(blog_id => $blog1->id, title => 'title11', text => 'first'); +$entry11->save; +my $entry12 = Entry->new(blog_id => $blog1->id, title => 'title12', text => 'second'); +$entry12->save; +my $entry21 = Entry->new(blog_id => $blog2->id, title => 'title21', text => 'first'); +$entry21->save; +my $entry22 = Entry->new(blog_id => $blog2->id, title => 'title22', text => 'second'); +$entry22->save; + subtest 'as_subquery' => sub { - my $stmt = Ingredient->driver->prepare_statement('Ingredient', { col1 => 'sub1' }, { fetchonly => ['id'] }); + my $stmt = Blog->driver->prepare_statement('Blog', { name => 'foo' }, { fetchonly => ['id'] }); is(sql_normalize($stmt->as_subquery), sql_normalize(<<'EOF'), 'right sql'); -(SELECT ingredients.id FROM ingredients WHERE (ingredients.col1 = ?)) +(SELECT blog.id FROM blog WHERE (blog.name = ?)) EOF - is_deeply($stmt->{bind}, ['sub1'], 'right bind values'); + is_deeply($stmt->{bind}, ['foo'], 'right bind values'); $stmt->as('mysubquery'); is(sql_normalize($stmt->as_subquery), sql_normalize(<<'EOF'), 'right sql'); -(SELECT ingredients.id FROM ingredients WHERE (ingredients.col1 = ?)) AS mysubquery +(SELECT blog.id FROM blog WHERE (blog.name = ?)) AS mysubquery EOF }; subtest 'subquery in select clause' => sub { - subtest 'case1' => sub { - my $stmt = Recipe->driver->prepare_statement('Recipe', [{ title => 'title1' }], {}); - $stmt->add_select(Ingredient->driver->prepare_statement( - 'Ingredient', - [{ recipe_id => \'= recipes.recipe_id' }, { col1 => 'sub1' }], { fetchonly => ['id'] })); - - my $expected = sql_normalize(<<'EOF'); -SELECT - recipes.recipe_id, - recipes.title, - ( - SELECT ingredients.id - FROM ingredients - WHERE ((recipe_id = recipes.recipe_id)) AND ((col1 = ?)) - ) -FROM recipes -WHERE ((title = ?)) -EOF - - is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; - is_deeply($stmt->{bind}, ['sub1', 'title1'], 'right bind values'); - }; - - subtest 'with alias' => sub { - my $stmt = Recipe->driver->prepare_statement('Recipe', [], {}); - my $subquery = Ingredient->driver->prepare_statement( - 'Ingredient', - [{ recipe_id => \'= recipes.recipe_id' }], { fetchonly => ['id'] }); + subtest 'fetch blogs and include a entry with specific text if any' => sub { + my $stmt = Blog->driver->prepare_statement('Blog', [{ name => $blog1->name }], {}); + my $subquery = Entry->driver->prepare_statement( + 'Entry', + ordered_hashref(blog_id => \'= blog.id', text => 'second'), + { fetchonly => ['id'], limit => 1 }); $subquery->as('sub_alias'); $stmt->add_select($subquery); my $expected = sql_normalize(<<'EOF'); SELECT - recipes.recipe_id, - recipes.title, + blog.id, + blog.parent_id, + blog.name, ( - SELECT ingredients.id - FROM ingredients - WHERE ((recipe_id = recipes.recipe_id)) + SELECT entry.id + FROM entry + WHERE (entry.blog_id = blog.id) AND (entry.text = ?) + LIMIT 1 ) AS sub_alias -FROM recipes +FROM blog +WHERE ((name = ?)) EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; - is_deeply($stmt->{bind}, [], 'right bind values'); + is_deeply($stmt->{bind}, ['second', $blog1->name], 'right bind values'); + my @res = search_by_prepared_statement('Blog', $stmt); + is scalar(@res), 1; + is scalar(keys %{ $res[0]{column_values} }), 4; + is($res[0]{column_values}{id}, $blog1->id); + is($res[0]{column_values}{sub_alias}, $entry12->id); + }; + + subtest 'error occurs without alias' => sub { + my $stmt = Blog->driver->prepare_statement('Blog', [], {}); + my $subquery = Entry->driver->prepare_statement( + 'Entry', + [{ blog_id => \'= blog.id' }], { fetchonly => ['id'], limit => 1 }); + eval { $stmt->add_select($subquery) }; + like $@, qr/requires an alias/; }; }; subtest 'subquery in from clause' => sub { - subtest 'case1' => sub { - my $stmt = Recipe->driver->prepare_statement('Recipe', [{ title => 'title1' }], {}); - my $subquery = Ingredient->driver->prepare_statement( - 'Ingredient', - [{ recipe_id => \'= recipes.recipe_id' }, { col1 => 'sub1' }], { fetchonly => ['id'] }); + subtest 'blogs that has entries with specific text' => sub { + my $subquery = Entry->driver->prepare_statement( + 'Entry', + { text => 'second' }, { fetchonly => ['id', 'blog_id', 'text'] }); + $subquery->as('sub'); + my $stmt = Blog->driver->prepare_statement( + 'Blog', [ + { 'blog.id' => \'= sub.blog_id' }, + { 'blog.id' => [$blog1->id, $blog2->id] }, # FIXME: table prefix should be added automatically (MTC-30879) + { 'sub.text' => 'second' }, + ], + {}); push @{ $stmt->from }, $subquery; my $expected = sql_normalize(<<'EOF'); SELECT - recipes.recipe_id, - recipes.title -FROM recipes, + blog.id, + blog.parent_id, + blog.name +FROM blog, ( - SELECT ingredients.id - FROM ingredients - WHERE ((recipe_id = recipes.recipe_id)) AND ((col1 = ?)) - ) -WHERE ((title = ?)) + SELECT entry.id, entry.blog_id, entry.text + FROM entry + WHERE (entry.text = ?) + ) AS sub +WHERE ((blog.id = sub.blog_id)) AND ((blog.id IN (?,?))) AND ((sub.text = ?)) EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; - is_deeply($stmt->{bind}, ['sub1', 'title1'], 'right bind values'); + is_deeply($stmt->{bind}, ['second', $blog1->id, $blog2->id, 'second'], 'right bind values'); + my @res = search_by_prepared_statement('Blog', $stmt); + is scalar(@res), 2; + is scalar(keys %{ $res[0]{column_values} }), 3; + is($res[0]{column_values}{id}, $blog1->id); }; - subtest 'with alias' => sub { - my $stmt = Recipe->driver->prepare_statement('Recipe', [], {}); - my $subquery = Ingredient->driver->prepare_statement( - 'Ingredient', - [{ recipe_id => \'= recipes.recipe_id' }], { fetchonly => ['id'] }); - $subquery->as('sub_alias'); + subtest 'select list includes sub query result' => sub { + my $subquery = Entry->driver->prepare_statement( + 'Entry', + { text => 'second' }, { fetchonly => ['id', 'blog_id'] }); + # $subquery->add_select('max(id)', 'max_entry_id'); + $subquery->as('sub'); + my $stmt = Blog->driver->prepare_statement( + 'Blog', [ + { 'blog.id' => \'= sub.blog_id' }, # FIXME: table prefix should be added automatically (MTC-30879) + { 'blog.id' => [$blog1->id, $blog2->id] }, # FIXME: table prefix should be added automatically (MTC-30879) + ], + {}); push @{ $stmt->from }, $subquery; + $stmt->add_select('sub.id', 'entry_id'); my $expected = sql_normalize(<<'EOF'); SELECT - recipes.recipe_id, - recipes.title -FROM recipes, + blog.id, + blog.parent_id, + blog.name, + sub.id entry_id +FROM blog, ( - SELECT ingredients.id - FROM ingredients - WHERE ((recipe_id = recipes.recipe_id)) - ) AS sub_alias + SELECT entry.id, entry.blog_id + FROM entry + WHERE (entry.text = ?) + ) AS sub +WHERE ((blog.id = sub.blog_id)) AND ((blog.id IN (?,?))) EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; - is_deeply($stmt->{bind}, [], 'right bind values'); + is_deeply($stmt->{bind}, ['second', $blog1->id, $blog2->id], 'right bind values'); + my @res = search_by_prepared_statement('Blog', $stmt); + is scalar(@res), 2; + is scalar(keys %{ $res[0]{column_values} }), 4; + is($res[0]{column_values}{entry_id}, $entry12->id); + is($res[1]{column_values}{entry_id}, $entry22->id); }; }; subtest 'subquery in where clause' => sub { - subtest 'case1' => sub { - my $stmt = Recipe->driver->prepare_statement( - 'Recipe', [ - { title => 'title1' }, - { - recipe_id => { - op => 'IN', - value => Ingredient->driver->prepare_statement( - 'Ingredient', - { col1 => { op => 'LIKE', value => 'sub1', escape => '!' } }, - { fetchonly => ['id'], limit => 2 }) } - }, - ], + subtest 'entries that belongs to subquery blogs' => sub { + my $stmt = Entry->driver->prepare_statement( + 'Entry', + ordered_hashref( + text => 'first', + blog_id => { + op => 'IN', + value => Blog->driver->prepare_statement( + 'Blog', + { name => { op => 'LIKE', value => 'blog1', escape => '!' } }, + { fetchonly => ['id'], limit => 2 } + ), + } + ), { limit => 4 }); my $expected = sql_normalize(<<'EOF'); SELECT - recipes.recipe_id, recipes.title + entry.id, entry.blog_id, entry.title, entry.text FROM - recipes + entry WHERE - ((title = ?)) + (entry.text = ?) AND - ((recipe_id IN (SELECT ingredients.id FROM ingredients WHERE (ingredients.col1 LIKE ? ESCAPE '!') LIMIT 2))) + (entry.blog_id IN (SELECT blog.id FROM blog WHERE (blog.name LIKE ? ESCAPE '!') LIMIT 2)) LIMIT 4 EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; - is_deeply($stmt->{bind}, ['title1', 'sub1'], 'right bind values'); + is_deeply($stmt->{bind}, ['first', 'blog1'], 'right bind values'); + my @res = search_by_prepared_statement('Blog', $stmt); + is scalar(@res), 1; + is scalar(keys %{ $res[0]{column_values} }), 4; + is($res[0]{column_values}{id}, $blog1->id); }; subtest 'case2' => sub { - my $stmt = Recipe->driver->prepare_statement( - 'Recipe', + my $stmt = Entry->driver->prepare_statement( + 'Entry', [[ - { title => 'title1' }, + { text => 'first' }, '-or', { - recipe_id => { + blog_id => { op => 'IN', - value => Ingredient->driver->prepare_statement( - 'Ingredient', [ - { col1 => { op => 'LIKE', value => 'sub1', escape => '!' } }, - { col2 => { op => 'LIKE', value => 'sub2', escape => '!' } }, + value => Blog->driver->prepare_statement( + 'Blog', [ + { name => { op => 'LIKE', value => 'blog!%', escape => '!' } }, + { name => { op => 'LIKE', value => '!%2', escape => '!' } }, ], { fetchonly => ['id'], limit => 2 }) } }, '-or', - { title => 'title2' }, + { text => 'second' }, ], - { title3 => 'title3' }, + { id => [$entry11->id, $entry12->id] }, ], { limit => 4 }); my $expected = sql_normalize(<<'EOF'); SELECT - recipes.recipe_id, recipes.title + entry.id, entry.blog_id, entry.title, entry.text FROM - recipes + entry WHERE ( - ((title = ?)) + ((text = ?)) OR - ((recipe_id IN ( - SELECT ingredients.id - FROM ingredients - WHERE ((col1 LIKE ? ESCAPE '!')) AND ((col2 LIKE ? ESCAPE '!')) + ((blog_id IN ( + SELECT blog.id + FROM blog + WHERE ((name LIKE ? ESCAPE '!')) AND ((name LIKE ? ESCAPE '!')) LIMIT 2 ))) OR - ((title = ?)) + ((text = ?)) ) AND ( - (title3 = ?) + (id IN (?,?)) ) LIMIT 4 EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; - is_deeply($stmt->{bind}, ['title1', 'sub1', 'sub2', 'title2', 'title3'], 'right bind values'); + is_deeply($stmt->{bind}, ['first', 'blog!%', '!%2', 'second', $blog1->id, $blog2->id], 'right bind values'); + my @res = search_by_prepared_statement('Blog', $stmt); + is scalar(@res), 2; + is scalar(keys %{ $res[0]{column_values} }), 4; + is($res[0]{column_values}{id}, $blog1->id); + is($res[1]{column_values}{id}, $blog2->id); }; }; subtest 'subquery in multiple clauses' => sub { - my $sub1 = Ingredient->driver->prepare_statement('Ingredient', { id => 1 }, { fetchonly => ['id'] }); - my $sub2 = Ingredient->driver->prepare_statement('Ingredient', { id => 2 }, { fetchonly => ['id'] }); - my $sub3 = Ingredient->driver->prepare_statement('Ingredient', { id => 3 }, { fetchonly => ['id'] }); + my $sub1 = Entry->driver->prepare_statement( + 'Entry', + ordered_hashref(blog_id => \'= blog.id', id => { op => '<', value => 99 }), { fetchonly => ['id'] }); + $sub1->select(['max(id)']); + my $sub2 = Entry->driver->prepare_statement('Entry', { text => 'second' }, { fetchonly => ['id'] }); + my $sub3 = Entry->driver->prepare_statement('Entry', { text => 'second' }, { fetchonly => ['blog_id'] }); $sub1->as('sub1'); $sub2->as('sub2'); - $sub3->as('sub3'); - my $stmt = Recipe->driver->prepare_statement('Recipe', { recipe_id => { op => '=', value => $sub3 } }, {}); + $sub3->as('sub3'); # this will be ommitted in where clause + my $stmt = Blog->driver->prepare_statement('Blog', { id => { op => 'IN', value => $sub3 } }, {}); $stmt->add_select($sub1); push @{ $stmt->from }, $sub2; my $expected = sql_normalize(<<'EOF'); SELECT - recipes.recipe_id, - recipes.title, - (SELECT ingredients.id FROM ingredients WHERE (ingredients.id = ?)) AS sub1 + blog.id, + blog.parent_id, + blog.name, + (SELECT max(id) FROM entry WHERE (entry.blog_id = blog.id) AND (entry.id < ?)) AS sub1 FROM - recipes, - (SELECT ingredients.id FROM ingredients WHERE (ingredients.id = ?)) AS sub2 + blog, + (SELECT entry.id FROM entry WHERE (entry.text = ?)) AS sub2 WHERE - (recipes.recipe_id = (SELECT ingredients.id FROM ingredients WHERE (ingredients.id = ?)) AS sub3) + (blog.id IN (SELECT entry.blog_id FROM entry WHERE (entry.text = ?))) EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; - is_deeply($stmt->{bind}, ['1', '2', '3'], 'right bind values'); + is_deeply($stmt->{bind}, ['99', 'second', 'second'], 'right bind values'); + my @res = search_by_prepared_statement('Blog', $stmt); + is scalar(@res), 4; + is($res[0]{column_values}{id}, $blog1->id); + is($res[0]{column_values}{sub1}, $entry12->id); + is($res[1]{column_values}{id}, $blog1->id); + is($res[1]{column_values}{sub1}, $entry12->id); + is($res[2]{column_values}{id}, $blog2->id); + is($res[2]{column_values}{sub1}, $entry22->id); + is($res[3]{column_values}{id}, $blog2->id); + is($res[3]{column_values}{sub1}, $entry22->id); }; -subtest 'subquery in select list actually works' => sub { - - require Data::ObjectDriver::Driver::DBI; - my $prepare_statement_org = \&Data::ObjectDriver::Driver::DBI::prepare_statement; - - { - my $r = Recipe->new; - $r->title('MyRecipe1'); - $r->save; - my $i = Ingredient->new; - $i->recipe_id($r->recipe_id); - $i->name('salt'); - $i->save; +sub search_by_prepared_statement { + my ($class, $stmt) = @_; + my $driver = $class->driver; + my $rec = {}; + my $sql = $stmt->as_sql; + my @bind; + my $map = $stmt->select_map; + for my $col (@{ $stmt->select }) { + push @bind, \$rec->{ $map->{$col} || $col }; } - subtest 'case1' => sub { - my $stmt; - my $sub_stmt; - local *Data::ObjectDriver::Driver::DBI::prepare_statement = sub { - $stmt = $prepare_statement_org->(@_); - $sub_stmt = $prepare_statement_org->( - Ingredient->driver, - 'Ingredient', - [{ 'ingredients.recipe_id' => \'= recipes.recipe_id' }], { fetchonly => ['name'] }); - $sub_stmt->as('ingredient_name'); - $stmt->add_select($sub_stmt); - return $stmt; - }; - - my @recipes = eval { Recipe->search({}, {}) }; - - is sql_normalize($stmt->as_sql), sql_normalize(<<'EOF'), 'right sql'; -SELECT - recipes.recipe_id, - recipes.title, - ( - SELECT ingredients.name - FROM ingredients - WHERE ((ingredients.recipe_id = recipes.recipe_id)) - ) AS ingredient_name -FROM recipes -EOF - - is_deeply( - $stmt->select_map, { - 'recipes.recipe_id' => 'recipe_id', - 'recipes.title' => 'title', - "$sub_stmt" => 'ingredient_name', - }, - 'right select map' - ); - ok(!$@, 'no error') || note $@; - is scalar(@recipes), 1, 'right number of results'; - is $recipes[0]{column_values}{ingredient_name}, 'salt', 'right ingredient_name'; # XXX is it expected? + my $dbh = $driver->r_handle($class->properties->{db}); + $driver->start_query($sql, $stmt->{bind}); + + my $sth = $dbh->prepare($sql); + $sth->execute(@{ $stmt->{bind} }); + $sth->bind_columns(undef, @bind); + + my $iter = sub { + my $d = $driver; + unless ($sth->fetch) { + _close_sth($sth); + $driver->end_query($sth); + return; + } + return $driver->load_object_from_rec($class, $rec); }; - subtest 'without alias' => sub { - my $stmt; - my $sub_stmt; - local *Data::ObjectDriver::Driver::DBI::prepare_statement = sub { - $stmt = $prepare_statement_org->(@_); - $sub_stmt = $prepare_statement_org->( - Ingredient->driver, - 'Ingredient', - [{ 'ingredients.recipe_id' => \'= recipes.recipe_id' }], { fetchonly => ['name'] }); - $stmt->add_select($sub_stmt); - return $stmt; - }; - - my @recipes = eval { Recipe->search({}, {}) }; - - is sql_normalize($stmt->as_sql), sql_normalize(<<'EOF'), 'right sql'; -SELECT - recipes.recipe_id, - recipes.title, - ( - SELECT ingredients.name - FROM ingredients - WHERE ((ingredients.recipe_id = recipes.recipe_id)) - ) -FROM recipes -EOF - - is_deeply( - $stmt->select_map, { - 'recipes.recipe_id' => 'recipe_id', - 'recipes.title' => 'title', - "$sub_stmt" => undef, - }, - 'right select map' + if (wantarray) { + my @objs = (); + while (my $obj = $iter->()) { + push @objs, $obj; + } + return @objs; + } else { + my $iterator = Data::ObjectDriver::Iterator->new( + $iter, sub { _close_sth($sth); $driver->end_query($sth) }, ); - ok(!$@, 'no error') || note $@; - is scalar(@recipes), 1, 'right number of results'; - is $recipes[0]{column_values}{"$sub_stmt"}, 'salt', 'right ingredient_name'; # XXX is it expected? - }; -}; + return $iterator; + } + return; +} + +sub _close_sth { + my $sth = shift; + $sth->finish; + undef $sth; +} sub sql_normalize { my $sql = shift; @@ -350,6 +365,6 @@ sub sql_normalize { } END { - disconnect_all(qw/Recipe Ingredient/); + disconnect_all(qw/Blog Entry/); teardown_dbs(qw( global )); } diff --git a/t/lib/Clone/PP.pm b/t/lib/Clone/PP.pm new file mode 100644 index 0000000..8d1aa25 --- /dev/null +++ b/t/lib/Clone/PP.pm @@ -0,0 +1,193 @@ +package Clone::PP; + +use 5.006; +use strict; +use warnings; +use vars qw($VERSION @EXPORT_OK); +use Exporter; + +$VERSION = 1.08; + +@EXPORT_OK = qw( clone ); +sub import { goto &Exporter::import } # lazy Exporter + +# These methods can be temporarily overridden to work with a given class. +use vars qw( $CloneSelfMethod $CloneInitMethod ); +$CloneSelfMethod ||= 'clone_self'; +$CloneInitMethod ||= 'clone_init'; + +# Used to detect looped networks and avoid infinite recursion. +use vars qw( %CloneCache ); + +# Generic cloning function +sub clone { + my $source = shift; + + return undef if not defined($source); + + # Optional depth limit: after a given number of levels, do shallow copy. + my $depth = shift; + return $source if ( defined $depth and $depth -- < 1 ); + + # Maintain a shared cache during recursive calls, then clear it at the end. + local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} ); + + return $CloneCache{ $source } if ( defined $CloneCache{ $source } ); + + # Non-reference values are copied shallowly + my $ref_type = ref $source or return $source; + + # Extract both the structure type and the class name of referent + my $class_name; + if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) { + $class_name = $ref_type; + $ref_type = $1; + # Some objects would prefer to clone themselves; check for clone_self(). + return $CloneCache{ $source } = $source->$CloneSelfMethod() + if $source->can($CloneSelfMethod); + } + + # To make a copy: + # - Prepare a reference to the same type of structure; + # - Store it in the cache, to avoid looping if it refers to itself; + # - Tie in to the same class as the original, if it was tied; + # - Assign a value to the reference by cloning each item in the original; + + my $copy; + if ($ref_type eq 'HASH') { + $CloneCache{ $source } = $copy = {}; + if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied } + %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source; + } elsif ($ref_type eq 'ARRAY') { + $CloneCache{ $source } = $copy = []; + if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied } + @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source; + } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') { + $CloneCache{ $source } = $copy = \( my $var = "" ); + if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied } + $$copy = clone($$source, $depth); + } else { + # Shallow copy anything else; this handles a reference to code, glob, regex + $CloneCache{ $source } = $copy = $source; + } + + # - Bless it into the same class as the original, if it was blessed; + # - If it has a post-cloning initialization method, call it. + if ( $class_name ) { + bless $copy, $class_name; + $copy->$CloneInitMethod() if $copy->can($CloneInitMethod); + } + + return $copy; +} + +1; + +__END__ + +=head1 NAME + +Clone::PP - Recursively copy Perl datatypes + +=head1 SYNOPSIS + + use Clone::PP qw(clone); + + $item = { 'foo' => 'bar', 'move' => [ 'zig', 'zag' ] }; + $copy = clone( $item ); + + $item = [ 'alpha', 'beta', { 'gamma' => 'vlissides' } ]; + $copy = clone( $item ); + + $item = Foo->new(); + $copy = clone( $item ); + +Or as an object method: + + require Clone::PP; + push @Foo::ISA, 'Clone::PP'; + + $item = Foo->new(); + $copy = $item->clone(); + +=head1 DESCRIPTION + +This module provides a general-purpose clone function to make deep +copies of Perl data structures. It calls itself recursively to copy +nested hash, array, scalar and reference types, including tied +variables and objects. + +The clone() function takes a scalar argument to copy. To duplicate +arrays or hashes, pass them in by reference: + + my $copy = clone(\@array); my @copy = @{ clone(\@array) }; + my $copy = clone(\%hash); my %copy = %{ clone(\%hash) }; + +The clone() function also accepts an optional second parameter that +can be used to limit the depth of the copy. If you pass a limit of +0, clone will return the same value you supplied; for a limit of +1, a shallow copy is constructed; for a limit of 2, two layers of +copying are done, and so on. + + my $shallow_copy = clone( $item, 1 ); + +To allow objects to intervene in the way they are copied, the +clone() function checks for a couple of optional methods. If an +object provides a method named C, it is called and the +result returned without further processing. Alternately, if an +object provides a method named C, it is called on the +copied object before it is returned. + +=head1 BUGS + +Some data types, such as globs, regexes, and code refs, are always copied shallowly. + +References to hash elements are not properly duplicated. (This is why two tests in t/dclone.t that are marked "todo".) For example, the following test should succeed but does not: + + my $hash = { foo => 1 }; + $hash->{bar} = \{ $hash->{foo} }; + my $copy = clone( \%hash ); + $hash->{foo} = 2; + $copy->{foo} = 2; + ok( $hash->{bar} == $copy->{bar} ); + +To report bugs via the CPAN web tracking system, go to +C or send mail +to C, replacing C<#> with C<@>. + +=head1 SEE ALSO + +L - a baseclass which provides a C method. + +L - find-grained cloning for Moose objects. + +The C function in L. + +L - +polymorphic data cloning (see its documentation for what that means). + +L - use whichever of the cloning methods is available. + +=head1 REPOSITORY + +L + +=head1 AUTHOR AND CREDITS + +Developed by Matthew Simon Cavalletto at Evolution Softworks. +More free Perl software is available at C. + + +=head1 COPYRIGHT AND LICENSE + +Copyright 2003 Matthew Simon Cavalletto. You may contact the author +directly at C or C. + +Code initially derived from Ref.pm. Portions Copyright 1994 David Muir Sharnoff. + +Interface based by Clone by Ray Finch with contributions from chocolateboy. +Portions Copyright 2001 Ray Finch. Portions Copyright 2001 chocolateboy. + +You may use, modify, and distribute this software under the same terms as Perl. + +=cut diff --git a/t/lib/Tie/IxHash.pm b/t/lib/Tie/IxHash.pm new file mode 100644 index 0000000..5b60043 --- /dev/null +++ b/t/lib/Tie/IxHash.pm @@ -0,0 +1,651 @@ +# +# Tie/IxHash.pm +# +# Indexed hash implementation for Perl +# +# See below for documentation. +# + +require 5.005; + +package Tie::IxHash; +use strict; +use integer; +require Tie::Hash; +use vars qw/@ISA $VERSION/; +@ISA = qw(Tie::Hash); + +$VERSION = $VERSION = '1.23'; + +# +# standard tie functions +# + +sub TIEHASH { + my($c) = shift; + my($s) = []; + $s->[0] = {}; # hashkey index + $s->[1] = []; # array of keys + $s->[2] = []; # array of data + $s->[3] = 0; # iter count + + bless $s, $c; + + $s->Push(@_) if @_; + + return $s; +} + +#sub DESTROY {} # costly if there's nothing to do + +sub FETCH { + my($s, $k) = (shift, shift); + return exists( $s->[0]{$k} ) ? $s->[2][ $s->[0]{$k} ] : undef; +} + +sub STORE { + my($s, $k, $v) = (shift, shift, shift); + + if (exists $s->[0]{$k}) { + my($i) = $s->[0]{$k}; + $s->[1][$i] = $k; + $s->[2][$i] = $v; + $s->[0]{$k} = $i; + } + else { + push(@{$s->[1]}, $k); + push(@{$s->[2]}, $v); + $s->[0]{$k} = $#{$s->[1]}; + } +} + +sub DELETE { + my($s, $k) = (shift, shift); + + if (exists $s->[0]{$k}) { + my($i) = $s->[0]{$k}; + for ($i+1..$#{$s->[1]}) { # reset higher elt indexes + $s->[0]{ $s->[1][$_] }--; # timeconsuming, is there is better way? + } + if ( $i == $s->[3]-1 ) { + $s->[3]--; + } + delete $s->[0]{$k}; + splice @{$s->[1]}, $i, 1; + return (splice(@{$s->[2]}, $i, 1))[0]; + } + return undef; +} + +sub EXISTS { + exists $_[0]->[0]{ $_[1] }; +} + +sub FIRSTKEY { + $_[0][3] = 0; + &NEXTKEY; +} + +sub NEXTKEY { + return $_[0][1][ $_[0][3]++ ] if ($_[0][3] <= $#{ $_[0][1] } ); + return undef; +} + + + +# +# +# class functions that provide additional capabilities +# +# + +sub new { TIEHASH(@_) } + +sub Clear { + my $s = shift; + $s->[0] = {}; # hashkey index + $s->[1] = []; # array of keys + $s->[2] = []; # array of data + $s->[3] = 0; # iter count + return; +} + +# +# add pairs to end of indexed hash +# note that if a supplied key exists, it will not be reordered +# +sub Push { + my($s) = shift; + while (@_) { + $s->STORE(shift, shift); + } + return scalar(@{$s->[1]}); +} + +sub Push2 { + my($s) = shift; + $s->Splice($#{$s->[1]}+1, 0, @_); + return scalar(@{$s->[1]}); +} + +# +# pop last k-v pair +# +sub Pop { + my($s) = shift; + my($k, $v, $i); + $k = pop(@{$s->[1]}); + $v = pop(@{$s->[2]}); + if (defined $k) { + delete $s->[0]{$k}; + return ($k, $v); + } + return undef; +} + +sub Pop2 { + return $_[0]->Splice(-1); +} + +# +# shift +# +sub Shift { + my($s) = shift; + my($k, $v, $i); + $k = shift(@{$s->[1]}); + $v = shift(@{$s->[2]}); + if (defined $k) { + delete $s->[0]{$k}; + for (keys %{$s->[0]}) { + $s->[0]{$_}--; + } + return ($k, $v); + } + return undef; +} + +sub Shift2 { + return $_[0]->Splice(0, 1); +} + +# +# unshift +# if a supplied key exists, it will not be reordered +# +sub Unshift { + my($s) = shift; + my($k, $v, @k, @v, $len, $i); + + while (@_) { + ($k, $v) = (shift, shift); + if (exists $s->[0]{$k}) { + $i = $s->[0]{$k}; + $s->[1][$i] = $k; + $s->[2][$i] = $v; + $s->[0]{$k} = $i; + } + else { + push(@k, $k); + push(@v, $v); + $len++; + } + } + if (defined $len) { + for (keys %{$s->[0]}) { + $s->[0]{$_} += $len; + } + $i = 0; + for (@k) { + $s->[0]{$_} = $i++; + } + unshift(@{$s->[1]}, @k); + return unshift(@{$s->[2]}, @v); + } + return scalar(@{$s->[1]}); +} + +sub Unshift2 { + my($s) = shift; + $s->Splice(0,0,@_); + return scalar(@{$s->[1]}); +} + +# +# splice +# +# any existing hash key order is preserved. the value is replaced for +# such keys, and the new keys are spliced in the regular fashion. +# +# supports -ve offsets but only +ve lengths +# +# always assumes a 0 start offset +# +sub Splice { + my($s, $start, $len) = (shift, shift, shift); + my($k, $v, @k, @v, @r, $i, $siz); + my($end); # inclusive + + # XXX inline this + ($start, $end, $len) = $s->_lrange($start, $len); + + if (defined $start) { + if ($len > 0) { + my(@k) = splice(@{$s->[1]}, $start, $len); + my(@v) = splice(@{$s->[2]}, $start, $len); + while (@k) { + $k = shift(@k); + delete $s->[0]{$k}; + push(@r, $k, shift(@v)); + } + for ($start..$#{$s->[1]}) { + $s->[0]{$s->[1][$_]} -= $len; + } + } + while (@_) { + ($k, $v) = (shift, shift); + if (exists $s->[0]{$k}) { + # $s->STORE($k, $v); + $i = $s->[0]{$k}; + $s->[1][$i] = $k; + $s->[2][$i] = $v; + $s->[0]{$k} = $i; + } + else { + push(@k, $k); + push(@v, $v); + $siz++; + } + } + if (defined $siz) { + for ($start..$#{$s->[1]}) { + $s->[0]{$s->[1][$_]} += $siz; + } + $i = $start; + for (@k) { + $s->[0]{$_} = $i++; + } + splice(@{$s->[1]}, $start, 0, @k); + splice(@{$s->[2]}, $start, 0, @v); + } + } + return @r; +} + +# +# delete elements specified by key +# other elements higher than the one deleted "slide" down +# +sub Delete { + my($s) = shift; + + for (@_) { + # + # XXX potential optimization: could do $s->DELETE only if $#_ < 4. + # otherwise, should reset all the hash indices in one loop + # + $s->DELETE($_); + } +} + +# +# replace hash element at specified index +# +# if the optional key is not supplied the value at index will simply be +# replaced without affecting the order. +# +# if an element with the supplied key already exists, it will be deleted first. +# +# returns the key of replaced value if it succeeds. +# +sub Replace { + my($s) = shift; + my($i, $v, $k) = (shift, shift, shift); + if (defined $i and $i <= $#{$s->[1]} and $i >= 0) { + if (defined $k) { + delete $s->[0]{ $s->[1][$i] }; + $s->DELETE($k) ; #if exists $s->[0]{$k}; + $s->[1][$i] = $k; + $s->[2][$i] = $v; + $s->[0]{$k} = $i; + return $k; + } + else { + $s->[2][$i] = $v; + return $s->[1][$i]; + } + } + return undef; +} + +# +# Given an $start and $len, returns a legal start and end (where start <= end) +# for the current hash. +# Legal range is defined as 0 to $#s+1 +# $len defaults to number of elts upto end of list +# +# 0 1 2 ... +# | X | X | X ... X | X | X | +# -2 -1 (no -0 alas) +# X's above are the elements +# +sub _lrange { + my($s) = shift; + my($offset, $len) = @_; + my($start, $end); # both inclusive + my($size) = $#{$s->[1]}+1; + + return undef unless defined $offset; + if($offset < 0) { + $start = $offset + $size; + $start = 0 if $start < 0; + } + else { + ($offset > $size) ? ($start = $size) : ($start = $offset); + } + + if (defined $len) { + $len = -$len if $len < 0; + $len = $size - $start if $len > $size - $start; + } + else { + $len = $size - $start; + } + $end = $start + $len - 1; + + return ($start, $end, $len); +} + +# +# Return keys at supplied indices +# Returns all keys if no args. +# +sub Keys { + my($s) = shift; + return ( @_ == 1 + ? $s->[1][$_[0]] + : ( @_ + ? @{$s->[1]}[@_] + : @{$s->[1]} ) ); +} + +# +# Returns values at supplied indices +# Returns all values if no args. +# +sub Values { + my($s) = shift; + return ( @_ == 1 + ? $s->[2][$_[0]] + : ( @_ + ? @{$s->[2]}[@_] + : @{$s->[2]} ) ); +} + +# +# get indices of specified hash keys +# +sub Indices { + my($s) = shift; + return ( @_ == 1 ? $s->[0]{$_[0]} : @{$s->[0]}{@_} ); +} + +# +# number of k-v pairs in the ixhash +# note that this does not equal the highest index +# owing to preextended arrays +# +sub Length { + return scalar @{$_[0]->[1]}; +} + +# +# Reorder the hash in the supplied key order +# +# warning: any unsupplied keys will be lost from the hash +# any supplied keys that dont exist in the hash will be ignored +# +sub Reorder { + my($s) = shift; + my(@k, @v, %x, $i); + return unless @_; + + $i = 0; + for (@_) { + if (exists $s->[0]{$_}) { + push(@k, $_); + push(@v, $s->[2][ $s->[0]{$_} ] ); + $x{$_} = $i++; + } + } + $s->[1] = \@k; + $s->[2] = \@v; + $s->[0] = \%x; + return $s; +} + +sub SortByKey { + my($s) = shift; + $s->Reorder(sort $s->Keys); +} + +sub SortByValue { + my($s) = shift; + $s->Reorder(sort { $s->FETCH($a) cmp $s->FETCH($b) } $s->Keys) +} + +1; +__END__ + +=head1 NAME + +Tie::IxHash - ordered associative arrays for Perl + + +=head1 SYNOPSIS + + # simple usage + use Tie::IxHash; + tie HASHVARIABLE, 'Tie::IxHash' [, LIST]; + + # OO interface with more powerful features + use Tie::IxHash; + TIEOBJECT = Tie::IxHash->new( [LIST] ); + TIEOBJECT->Splice( OFFSET [, LENGTH [, LIST]] ); + TIEOBJECT->Push( LIST ); + TIEOBJECT->Pop; + TIEOBJECT->Shift; + TIEOBJECT->Unshift( LIST ); + TIEOBJECT->Keys( [LIST] ); + TIEOBJECT->Values( [LIST] ); + TIEOBJECT->Indices( LIST ); + TIEOBJECT->Delete( [LIST] ); + TIEOBJECT->Replace( OFFSET, VALUE, [KEY] ); + TIEOBJECT->Reorder( LIST ); + TIEOBJECT->SortByKey; + TIEOBJECT->SortByValue; + TIEOBJECT->Length; + + +=head1 DESCRIPTION + +This Perl module implements Perl hashes that preserve the order in which the +hash elements were added. The order is not affected when values +corresponding to existing keys in the IxHash are changed. The elements can +also be set to any arbitrary supplied order. The familiar perl array +operations can also be performed on the IxHash. + + +=head2 Standard C Interface + +The standard C mechanism is available. This interface is +recommended for simple uses, since the usage is exactly the same as +regular Perl hashes after the C is declared. + + +=head2 Object Interface + +This module also provides an extended object-oriented interface that can be +used for more powerful operations with the IxHash. The following methods +are available: + +=over 8 + +=item FETCH, STORE, DELETE, EXISTS + +These standard C methods mandated by Perl can be used directly. +See the C entry in perlfunc(1) for details. + +=item Push, Pop, Shift, Unshift, Splice + +These additional methods resembling Perl functions are available for +operating on key-value pairs in the IxHash. The behavior is the same as the +corresponding perl functions, except when a supplied hash key already exists +in the hash. In that case, the existing value is updated but its order is +not affected. To unconditionally alter the order of a supplied key-value +pair, first C the IxHash element. + +=item Keys + +Returns an array of IxHash element keys corresponding to the list of supplied +indices. Returns an array of all the keys if called without arguments. +Note the return value is mostly only useful when used in a list context +(since perl will convert it to the number of elements in the array when +used in a scalar context, and that may not be very useful). + +If a single argument is given, returns the single key corresponding to +the index. This is usable in either scalar or list context. + +=item Values + +Returns an array of IxHash element values corresponding to the list of supplied +indices. Returns an array of all the values if called without arguments. +Note the return value is mostly only useful when used in a list context +(since perl will convert it to the number of elements in the array when +used in a scalar context, and that may not be very useful). + +If a single argument is given, returns the single value corresponding to +the index. This is usable in either scalar or list context. + +=item Indices + +Returns an array of indices corresponding to the supplied list of keys. +Note the return value is mostly only useful when used in a list context +(since perl will convert it to the number of elements in the array when +used in a scalar context, and that may not be very useful). + +If a single argument is given, returns the single index corresponding to +the key. This is usable in either scalar or list context. + +=item Delete + +Removes elements with the supplied keys from the IxHash. + +=item Replace + +Substitutes the IxHash element at the specified index with the supplied +value-key pair. If a key is not supplied, simply substitutes the value at +index with the supplied value. If an element with the supplied key already +exists, it will be removed from the IxHash first. + +=item Reorder + +This method can be used to manipulate the internal order of the IxHash +elements by supplying a list of keys in the desired order. Note however, +that any IxHash elements whose keys are not in the list will be removed from +the IxHash. + +=item Length + +Returns the number of IxHash elements. + +=item SortByKey + +Reorders the IxHash elements by textual comparison of the keys. + +=item SortByValue + +Reorders the IxHash elements by textual comparison of the values. + +=item Clear + +Resets the IxHash to its pristine state: with no elements at all. + +=back + + +=head1 EXAMPLE + + use Tie::IxHash; + + # simple interface + $t = tie(%myhash, 'Tie::IxHash', 'a' => 1, 'b' => 2); + %myhash = (first => 1, second => 2, third => 3); + $myhash{fourth} = 4; + @keys = keys %myhash; + @values = values %myhash; + print("y") if exists $myhash{third}; + + # OO interface + $t = Tie::IxHash->new(first => 1, second => 2, third => 3); + $t->Push(fourth => 4); # same as $myhash{'fourth'} = 4; + ($k, $v) = $t->Pop; # $k is 'fourth', $v is 4 + $t->Unshift(neg => -1, zeroth => 0); + ($k, $v) = $t->Shift; # $k is 'neg', $v is -1 + @oneandtwo = $t->Splice(1, 2, foo => 100, bar => 101); + + @keys = $t->Keys; + @values = $t->Values; + @indices = $t->Indices('foo', 'zeroth'); + @itemkeys = $t->Keys(@indices); + @itemvals = $t->Values(@indices); + $t->Replace(2, 0.3, 'other'); + $t->Delete('second', 'zeroth'); + $len = $t->Length; # number of key-value pairs + + $t->Reorder(reverse @keys); + $t->SortByKey; + $t->SortByValue; + + +=head1 BUGS + +You cannot specify a negative length to C. Negative indexes are OK, +though. + + +=head1 NOTE + +Indexing always begins at 0 (despite the current C<$[> setting) for +all the functions. + + +=head1 TODO + +Addition of elements with keys that already exist to the end of the IxHash +must be controlled by a switch. + +Provide C interface when it stabilizes in Perl. + +Rewrite using XSUBs for efficiency. + + +=head1 AUTHOR + +Gurusamy Sarathy gsar@umich.edu + +Copyright (c) 1995 Gurusamy Sarathy. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + +=head1 VERSION + +Version 1.23 + + +=head1 SEE ALSO + +perl(1) + +=cut diff --git a/t/lib/sql/Blog.pm b/t/lib/sql/Blog.pm new file mode 100644 index 0000000..807bc71 --- /dev/null +++ b/t/lib/sql/Blog.pm @@ -0,0 +1,17 @@ +# $Id$ + +package Blog; +use strict; +use warnings; +use base 'Data::ObjectDriver::BaseObject'; +use Data::ObjectDriver::Driver::DBI; +use DodTestUtil; + +__PACKAGE__->install_properties({ + columns => ['id', 'parent_id', 'name'], + datasource => 'blog', + primary_key => 'id', + driver => Data::ObjectDriver::Driver::DBI->new(dsn => DodTestUtil::dsn('global')), +}); + +1; diff --git a/t/lib/sql/Entry.pm b/t/lib/sql/Entry.pm new file mode 100644 index 0000000..90bb474 --- /dev/null +++ b/t/lib/sql/Entry.pm @@ -0,0 +1,17 @@ +# $Id$ + +package Entry; +use strict; +use warnings; +use base 'Data::ObjectDriver::BaseObject'; +use Data::ObjectDriver::Driver::DBI; +use DodTestUtil; + +__PACKAGE__->install_properties({ + columns => ['id', 'blog_id', 'title', 'text'], + datasource => 'entry', + primary_key => 'id', + driver => Data::ObjectDriver::Driver::DBI->new(dsn => DodTestUtil::dsn('global')), +}); + +1; diff --git a/t/schemas/blog.sql b/t/schemas/blog.sql new file mode 100644 index 0000000..82ed167 --- /dev/null +++ b/t/schemas/blog.sql @@ -0,0 +1,5 @@ +CREATE TABLE blog ( + id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + parent_id INTEGER, + name VARCHAR(50) +) diff --git a/t/schemas/entry.sql b/t/schemas/entry.sql new file mode 100644 index 0000000..7328ab7 --- /dev/null +++ b/t/schemas/entry.sql @@ -0,0 +1,6 @@ +CREATE TABLE entry ( + id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, + blog_id INTEGER, + title VARCHAR(50), + text MEDIUMTEXT +) From af77ab55086c21b053ebaebcc597b771c9d01078 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 18 Sep 2025 23:12:00 +0900 Subject: [PATCH 15/26] add tests for bind aggregation on statement reuse --- t/11-sql-with-models.t | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 921d3b2..155b6fe 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -50,6 +50,21 @@ EOF EOF }; +subtest 'do not aggregate bind twice' => sub { + + my $stmt = Blog->driver->prepare_statement('Blog', [{ name => $blog1->name }], {}); + my $subquery = Entry->driver->prepare_statement( + 'Entry', + ordered_hashref(blog_id => \'= blog.id', text => 'second'), + { fetchonly => ['id'], limit => 1 }); + $subquery->as('sub'); + $stmt->add_select($subquery); + $stmt->as_sql; + is scalar(@{ $stmt->bind }), 2; + $stmt->as_sql; + is scalar(@{ $stmt->bind }), 2; +}; + subtest 'subquery in select clause' => sub { subtest 'fetch blogs and include a entry with specific text if any' => sub { From 3ab7a82ab23631d7f17252d7580c3af94c213ea0 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 18 Sep 2025 23:21:54 +0900 Subject: [PATCH 16/26] use modeuls after check_driver --- t/11-sql-with-models.t | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 155b6fe..5ec425d 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -7,12 +7,13 @@ use lib 't/lib'; use lib 't/lib/sql'; use Test::More tests => 6; use DodTestUtil; -use Blog; -use Entry; use Tie::IxHash; BEGIN { DodTestUtil->check_driver } +use Blog; +use Entry; + sub ordered_hashref { tie my %params, Tie::IxHash::, @_; return \%params; From 536bd3455d59ef3b6f6cddf2663c92fc044e81e7 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Thu, 18 Sep 2025 23:24:57 +0900 Subject: [PATCH 17/26] use done_testing --- t/11-sql-with-models.t | 4 +++- t/11-sql.t | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 5ec425d..e30e789 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -5,7 +5,7 @@ use warnings; use lib 't/lib'; use lib 't/lib/sql'; -use Test::More tests => 6; +use Test::More; use DodTestUtil; use Tie::IxHash; @@ -384,3 +384,5 @@ END { disconnect_all(qw/Blog Entry/); teardown_dbs(qw( global )); } + +done_testing; diff --git a/t/11-sql.t b/t/11-sql.t index 160a23c..6229472 100644 --- a/t/11-sql.t +++ b/t/11-sql.t @@ -3,7 +3,7 @@ use strict; use Data::ObjectDriver::SQL; -use Test::More tests => 110; +use Test::More; my $stmt = ns(); ok($stmt, 'Created SQL object'); @@ -406,3 +406,5 @@ is( ); sub ns { Data::ObjectDriver::SQL->new } + +done_testing; From 380249c7dcb16a71bf5e890200cc1bd370a92453 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 19 Sep 2025 00:21:03 +0900 Subject: [PATCH 18/26] do not use LIMIT with IN operator in test because mysql doesnt support it --- t/11-sql-with-models.t | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index e30e789..fccf94c 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -201,7 +201,7 @@ subtest 'subquery in where clause' => sub { value => Blog->driver->prepare_statement( 'Blog', { name => { op => 'LIKE', value => 'blog1', escape => '!' } }, - { fetchonly => ['id'], limit => 2 } + { fetchonly => ['id'] } ), } ), @@ -215,7 +215,7 @@ FROM WHERE (entry.text = ?) AND - (entry.blog_id IN (SELECT blog.id FROM blog WHERE (blog.name LIKE ? ESCAPE '!') LIMIT 2)) + (entry.blog_id IN (SELECT blog.id FROM blog WHERE (blog.name LIKE ? ESCAPE '!'))) LIMIT 4 EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; @@ -240,7 +240,7 @@ EOF { name => { op => 'LIKE', value => 'blog!%', escape => '!' } }, { name => { op => 'LIKE', value => '!%2', escape => '!' } }, ], - { fetchonly => ['id'], limit => 2 }) } + { fetchonly => ['id'] }) } }, '-or', { text => 'second' }, @@ -262,7 +262,6 @@ WHERE SELECT blog.id FROM blog WHERE ((name LIKE ? ESCAPE '!')) AND ((name LIKE ? ESCAPE '!')) - LIMIT 2 ))) OR ((text = ?)) From a5e173aadd7fa059849aacd80a3eca917c5c8b33 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 19 Sep 2025 07:11:33 +0900 Subject: [PATCH 19/26] fix test for mysql --- t/11-sql-with-models.t | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index fccf94c..541cc7e 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -290,7 +290,9 @@ subtest 'subquery in multiple clauses' => sub { $sub1->as('sub1'); $sub2->as('sub2'); $sub3->as('sub3'); # this will be ommitted in where clause - my $stmt = Blog->driver->prepare_statement('Blog', { id => { op => 'IN', value => $sub3 } }, {}); + my $stmt = Blog->driver->prepare_statement( + 'Blog', { id => { op => 'IN', value => $sub3 } }, + { sort => [{ column => 'id' }, { column => 'sub1' }] }); $stmt->add_select($sub1); push @{ $stmt->from }, $sub2; @@ -305,6 +307,7 @@ FROM (SELECT entry.id FROM entry WHERE (entry.text = ?)) AS sub2 WHERE (blog.id IN (SELECT entry.blog_id FROM entry WHERE (entry.text = ?))) +ORDER BY id ASC, sub1 ASC EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; is_deeply($stmt->{bind}, ['99', 'second', 'second'], 'right bind values'); From 10c86341ba4deac6468736f6188d47bd76da7fc4 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 19 Sep 2025 07:25:10 +0900 Subject: [PATCH 20/26] fix test for sqlite --- t/11-sql-with-models.t | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 541cc7e..c99df13 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -292,7 +292,7 @@ subtest 'subquery in multiple clauses' => sub { $sub3->as('sub3'); # this will be ommitted in where clause my $stmt = Blog->driver->prepare_statement( 'Blog', { id => { op => 'IN', value => $sub3 } }, - { sort => [{ column => 'id' }, { column => 'sub1' }] }); + { sort => [{ column => 'blog.id' }, { column => 'sub1' }] }); $stmt->add_select($sub1); push @{ $stmt->from }, $sub2; @@ -307,7 +307,7 @@ FROM (SELECT entry.id FROM entry WHERE (entry.text = ?)) AS sub2 WHERE (blog.id IN (SELECT entry.blog_id FROM entry WHERE (entry.text = ?))) -ORDER BY id ASC, sub1 ASC +ORDER BY blog.id ASC, sub1 ASC EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; is_deeply($stmt->{bind}, ['99', 'second', 'second'], 'right bind values'); From f59d139935f7a4790703a83528c7c642337d7b38 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 19 Sep 2025 11:53:37 +0900 Subject: [PATCH 21/26] revert uuv fix for ommitted alias --- lib/Data/ObjectDriver/Driver/DBI.pm | 2 +- t/11-sql-with-models.t | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Data/ObjectDriver/Driver/DBI.pm b/lib/Data/ObjectDriver/Driver/DBI.pm index d51cc8e..148db0d 100644 --- a/lib/Data/ObjectDriver/Driver/DBI.pm +++ b/lib/Data/ObjectDriver/Driver/DBI.pm @@ -184,7 +184,7 @@ sub fetch { my @bind; my $map = $stmt->select_map; for my $col (@{ $stmt->select }) { - push @bind, \$rec->{ $map->{$col} || $col }; + push @bind, \$rec->{ $map->{$col} }; } my $dbh = $driver->r_handle($class->properties->{db}); diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index c99df13..1c935e4 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -331,7 +331,7 @@ sub search_by_prepared_statement { my @bind; my $map = $stmt->select_map; for my $col (@{ $stmt->select }) { - push @bind, \$rec->{ $map->{$col} || $col }; + push @bind, \$rec->{ $map->{$col} }; } my $dbh = $driver->r_handle($class->properties->{db}); From dedf234b35faad19bead93ead0c6dd21026ad91b Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 19 Sep 2025 18:28:39 +0900 Subject: [PATCH 22/26] add_select now accepts subquery with alias --- lib/Data/ObjectDriver/SQL.pm | 29 +++++++++++++++++------------ t/11-sql-with-models.t | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+), 12 deletions(-) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index 5464ea6..7efa844 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -34,12 +34,14 @@ sub new { sub add_select { my $stmt = shift; my($term, $col) = @_; - $col ||= $term; push @{ $stmt->select }, $term; - if (blessed($term) && $col->isa('Data::ObjectDriver::SQL')) { - die 'Sub-query requires an alias by setting $stmt->as(...)' unless $term->as; - $stmt->select_map->{$term} = $term->as; + if (blessed($term) && $term->isa('Data::ObjectDriver::SQL')) { + my $alias = $col || $term->as; + die 'Sub-query requires an alias by setting $stmt->as(...)' unless $alias; + $stmt->select_map->{$term} = $alias; + $stmt->select_map_reverse->{$alias} = $term; } else { + $col ||= $term; $stmt->select_map->{$term} = $col; $stmt->select_map_reverse->{$col} = $term; } @@ -71,13 +73,15 @@ sub as_sql { if (@{ $stmt->select }) { $sql .= 'SELECT '; $sql .= 'DISTINCT ' if $stmt->distinct; + my $select_map = $stmt->select_map; $sql .= join(', ', map { my $col = $_; + my $alias = $select_map->{$col}; if (blessed($col) && $col->isa('Data::ObjectDriver::SQL')) { push @bind_for_select, @{ $col->{bind} }; - $col->as_subquery; + $col->as_subquery($alias); } else { - if (my $alias = $stmt->select_map->{$col}) { + if ($alias) { /(?:^|\.)\Q$alias\E$/ ? $col : "$col $alias"; } else { $col; @@ -144,10 +148,11 @@ sub as_sql { } sub as_subquery { - my $stmt = shift; - my $subquery = '('. $stmt->as_sql. ')'; - if ($stmt->as) { - $subquery .= ' AS ' . $stmt->as; + my ($stmt, $alias) = @_; + my $subquery = '(' . $stmt->as_sql . ')'; + $alias ||= $stmt->as; + if ($alias) { + $subquery .= ' AS ' . $alias; } $subquery; } @@ -273,8 +278,8 @@ sub add_having { # Carp::croak("Invalid/unsafe column name $col") unless $col =~ /^[\w\.]+$/; if (my $orig = $stmt->select_map_reverse->{$col}) { - $col = $orig; - } + $col = $orig; + } my($term, $bind) = $stmt->_mk_term($col, $val); push @{ $stmt->{having} }, "($term)"; diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 1c935e4..4f8d70c 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -109,6 +109,38 @@ EOF eval { $stmt->add_select($subquery) }; like $@, qr/requires an alias/; }; + + subtest 'set alias by add_select argument' => sub { + my $stmt = Blog->driver->prepare_statement('Blog', [{ name => $blog1->name }], {}); + my $subquery = Entry->driver->prepare_statement( + 'Entry', + ordered_hashref(blog_id => \'= blog.id', text => 'second'), + { fetchonly => ['id'], limit => 1 }); + $stmt->add_select($subquery, 'sub_alias'); + + my $expected = sql_normalize(<<'EOF'); +SELECT + blog.id, + blog.parent_id, + blog.name, + ( + SELECT entry.id + FROM entry + WHERE (entry.blog_id = blog.id) AND (entry.text = ?) + LIMIT 1 + ) AS sub_alias +FROM blog +WHERE ((name = ?)) +EOF + + is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; + is_deeply($stmt->{bind}, ['second', $blog1->name], 'right bind values'); + my @res = search_by_prepared_statement('Blog', $stmt); + is scalar(@res), 1; + is scalar(keys %{ $res[0]{column_values} }), 4; + is($res[0]{column_values}{id}, $blog1->id); + is($res[0]{column_values}{sub_alias}, $entry12->id); + }; }; subtest 'subquery in from clause' => sub { From 8ad033ed86d2bb51677a125156d79db0073d8437 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 19 Sep 2025 12:11:08 +0900 Subject: [PATCH 23/26] fix add_having on subquery alias --- lib/Data/ObjectDriver/SQL.pm | 4 ++++ t/11-sql-with-models.t | 27 +++++++++++++++++++++++++++ 2 files changed, 31 insertions(+) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index 7efa844..b63dce0 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -278,8 +278,12 @@ sub add_having { # Carp::croak("Invalid/unsafe column name $col") unless $col =~ /^[\w\.]+$/; if (my $orig = $stmt->select_map_reverse->{$col}) { + if (blessed($orig) && $orig->isa('Data::ObjectDriver::SQL')) { + # do nothins + } else { $col = $orig; } + } my($term, $bind) = $stmt->_mk_term($col, $val); push @{ $stmt->{having} }, "($term)"; diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index 4f8d70c..f681434 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -143,6 +143,33 @@ EOF }; }; +subtest 'select_map used in add_having' => sub { + my $stmt = Entry->driver->prepare_statement('Entry', {}, {}); + $stmt->add_select('count(*)', 'count'); + $stmt->group({column => 'blog_id'}); + $stmt->add_having(count => 2); + is sql_normalize($stmt->as_sql), sql_normalize(<<'EOF'); +SELECT entry.id, entry.blog_id, entry.title, entry.text, count(*) count +FROM entry +GROUP BY blog_id +HAVING (count(*) = ?) +EOF + is_deeply($stmt->{bind}, ['2'], 'right bind values'); + + my $subquery = Blog->driver->prepare_statement('Blog', {}, {}); + $stmt->add_select($subquery, 'sub'); + $stmt->add_having(sub => 3); + is sql_normalize($stmt->as_sql), sql_normalize(<<'EOF'); +SELECT + entry.id, entry.blog_id, entry.title, entry.text, count(*) count, + (SELECT blog.id, blog.parent_id, blog.name FROM blog) AS sub +FROM entry +GROUP BY blog_id +HAVING (count(*) = ?) AND (sub = ?) +EOF + is_deeply($stmt->{bind}, ['2', '3'], 'right bind values'); +}; + subtest 'subquery in from clause' => sub { subtest 'blogs that has entries with specific text' => sub { From 178b921ff16594f3f8e73b6dee97e38dcc5f9529 Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 19 Sep 2025 16:34:10 +0900 Subject: [PATCH 24/26] search method now accepts prepared statements --- lib/Data/ObjectDriver/Driver/DBI.pm | 25 +++++++----- t/11-sql-with-models.t | 63 ++++------------------------- 2 files changed, 23 insertions(+), 65 deletions(-) diff --git a/lib/Data/ObjectDriver/Driver/DBI.pm b/lib/Data/ObjectDriver/Driver/DBI.pm index 148db0d..69ee106 100644 --- a/lib/Data/ObjectDriver/Driver/DBI.pm +++ b/lib/Data/ObjectDriver/Driver/DBI.pm @@ -12,6 +12,7 @@ use Data::ObjectDriver::Errors; use Data::ObjectDriver::SQL; use Data::ObjectDriver::Driver::DBD; use Data::ObjectDriver::Iterator; +use Scalar::Util 'blessed'; my $ForkSafe = _is_fork_safe(); my %Handles; @@ -172,14 +173,20 @@ sub prepare_fetch { sub fetch { my $driver = shift; - my($rec, $class, $orig_terms, $orig_args) = @_; + my ($rec, $class, $terms_or_stmt, $orig_args) = @_; + my ($sql, $stmt); - if ($Data::ObjectDriver::RESTRICT_IO) { - use Data::Dumper; - die "Attempted DBI I/O while in restricted mode: fetch() " . Dumper($orig_terms, $orig_args); - } + if (blessed($terms_or_stmt) && $terms_or_stmt->isa('Data::ObjectDriver::SQL')) { + $sql = $terms_or_stmt->as_sql; + $stmt = $terms_or_stmt; + } else { + if ($Data::ObjectDriver::RESTRICT_IO) { + use Data::Dumper; + die "Attempted DBI I/O while in restricted mode: fetch() " . Dumper($terms_or_stmt, $orig_args); + } - my ($sql, $bind, $stmt) = $driver->prepare_fetch($class, $orig_terms, $orig_args); + ($sql, undef, $stmt) = $driver->prepare_fetch($class, $terms_or_stmt, $orig_args); + } my @bind; my $map = $stmt->select_map; @@ -218,11 +225,11 @@ sub load_object_from_rec { } sub search { - my($driver) = shift; - my($class, $terms, $args) = @_; + my ($driver) = shift; + my ($class, $terms_or_stmt, $args) = @_; my $rec = {}; - my $sth = $driver->fetch($rec, $class, $terms, $args); + my $sth = $driver->fetch($rec, $class, $terms_or_stmt, $args); my $iter = sub { ## This is kind of a hack--we need $driver to stay in scope, diff --git a/t/11-sql-with-models.t b/t/11-sql-with-models.t index f681434..3a508d3 100644 --- a/t/11-sql-with-models.t +++ b/t/11-sql-with-models.t @@ -94,7 +94,7 @@ EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; is_deeply($stmt->{bind}, ['second', $blog1->name], 'right bind values'); - my @res = search_by_prepared_statement('Blog', $stmt); + my @res = Blog->driver->search('Blog', $stmt); is scalar(@res), 1; is scalar(keys %{ $res[0]{column_values} }), 4; is($res[0]{column_values}{id}, $blog1->id); @@ -135,7 +135,7 @@ EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; is_deeply($stmt->{bind}, ['second', $blog1->name], 'right bind values'); - my @res = search_by_prepared_statement('Blog', $stmt); + my @res = Blog->driver->search('Blog', $stmt); is scalar(@res), 1; is scalar(keys %{ $res[0]{column_values} }), 4; is($res[0]{column_values}{id}, $blog1->id); @@ -202,7 +202,7 @@ EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; is_deeply($stmt->{bind}, ['second', $blog1->id, $blog2->id, 'second'], 'right bind values'); - my @res = search_by_prepared_statement('Blog', $stmt); + my @res = Blog->driver->search('Blog', $stmt); is scalar(@res), 2; is scalar(keys %{ $res[0]{column_values} }), 3; is($res[0]{column_values}{id}, $blog1->id); @@ -240,7 +240,7 @@ EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; is_deeply($stmt->{bind}, ['second', $blog1->id, $blog2->id], 'right bind values'); - my @res = search_by_prepared_statement('Blog', $stmt); + my @res = Blog->driver->search('Blog', $stmt); is scalar(@res), 2; is scalar(keys %{ $res[0]{column_values} }), 4; is($res[0]{column_values}{entry_id}, $entry12->id); @@ -279,7 +279,7 @@ LIMIT 4 EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; is_deeply($stmt->{bind}, ['first', 'blog1'], 'right bind values'); - my @res = search_by_prepared_statement('Blog', $stmt); + my @res = Blog->driver->search('Blog', $stmt); is scalar(@res), 1; is scalar(keys %{ $res[0]{column_values} }), 4; is($res[0]{column_values}{id}, $blog1->id); @@ -331,7 +331,7 @@ LIMIT 4 EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; is_deeply($stmt->{bind}, ['first', 'blog!%', '!%2', 'second', $blog1->id, $blog2->id], 'right bind values'); - my @res = search_by_prepared_statement('Blog', $stmt); + my @res = Blog->driver->search('Blog', $stmt); is scalar(@res), 2; is scalar(keys %{ $res[0]{column_values} }), 4; is($res[0]{column_values}{id}, $blog1->id); @@ -370,7 +370,7 @@ ORDER BY blog.id ASC, sub1 ASC EOF is sql_normalize($stmt->as_sql), sql_normalize($expected), 'right sql'; is_deeply($stmt->{bind}, ['99', 'second', 'second'], 'right bind values'); - my @res = search_by_prepared_statement('Blog', $stmt); + my @res = Blog->driver->search('Blog', $stmt); is scalar(@res), 4; is($res[0]{column_values}{id}, $blog1->id); is($res[0]{column_values}{sub1}, $entry12->id); @@ -382,55 +382,6 @@ EOF is($res[3]{column_values}{sub1}, $entry22->id); }; -sub search_by_prepared_statement { - my ($class, $stmt) = @_; - my $driver = $class->driver; - my $rec = {}; - my $sql = $stmt->as_sql; - my @bind; - my $map = $stmt->select_map; - for my $col (@{ $stmt->select }) { - push @bind, \$rec->{ $map->{$col} }; - } - - my $dbh = $driver->r_handle($class->properties->{db}); - $driver->start_query($sql, $stmt->{bind}); - - my $sth = $dbh->prepare($sql); - $sth->execute(@{ $stmt->{bind} }); - $sth->bind_columns(undef, @bind); - - my $iter = sub { - my $d = $driver; - unless ($sth->fetch) { - _close_sth($sth); - $driver->end_query($sth); - return; - } - return $driver->load_object_from_rec($class, $rec); - }; - - if (wantarray) { - my @objs = (); - while (my $obj = $iter->()) { - push @objs, $obj; - } - return @objs; - } else { - my $iterator = Data::ObjectDriver::Iterator->new( - $iter, sub { _close_sth($sth); $driver->end_query($sth) }, - ); - return $iterator; - } - return; -} - -sub _close_sth { - my $sth = shift; - $sth->finish; - undef $sth; -} - sub sql_normalize { my $sql = shift; $sql =~ s{\s+}{ }g; From ccdc5612e23771c2c25c48c9fab2634e82affa6c Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 19 Sep 2025 16:43:35 +0900 Subject: [PATCH 25/26] add a test dependency --- cpanfile | 1 + t/lib/Clone/PP.pm | 193 ------------- t/lib/Tie/IxHash.pm | 651 -------------------------------------------- 3 files changed, 1 insertion(+), 844 deletions(-) delete mode 100644 t/lib/Clone/PP.pm delete mode 100644 t/lib/Tie/IxHash.pm diff --git a/cpanfile b/cpanfile index 14019ac..f4639d0 100644 --- a/cpanfile +++ b/cpanfile @@ -22,6 +22,7 @@ on develop => sub { on test => sub { requires 'version'; + requires 'Tie::IxHash'; }; feature 'test_sqlite', 'Test SQLite' => sub { diff --git a/t/lib/Clone/PP.pm b/t/lib/Clone/PP.pm deleted file mode 100644 index 8d1aa25..0000000 --- a/t/lib/Clone/PP.pm +++ /dev/null @@ -1,193 +0,0 @@ -package Clone::PP; - -use 5.006; -use strict; -use warnings; -use vars qw($VERSION @EXPORT_OK); -use Exporter; - -$VERSION = 1.08; - -@EXPORT_OK = qw( clone ); -sub import { goto &Exporter::import } # lazy Exporter - -# These methods can be temporarily overridden to work with a given class. -use vars qw( $CloneSelfMethod $CloneInitMethod ); -$CloneSelfMethod ||= 'clone_self'; -$CloneInitMethod ||= 'clone_init'; - -# Used to detect looped networks and avoid infinite recursion. -use vars qw( %CloneCache ); - -# Generic cloning function -sub clone { - my $source = shift; - - return undef if not defined($source); - - # Optional depth limit: after a given number of levels, do shallow copy. - my $depth = shift; - return $source if ( defined $depth and $depth -- < 1 ); - - # Maintain a shared cache during recursive calls, then clear it at the end. - local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} ); - - return $CloneCache{ $source } if ( defined $CloneCache{ $source } ); - - # Non-reference values are copied shallowly - my $ref_type = ref $source or return $source; - - # Extract both the structure type and the class name of referent - my $class_name; - if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) { - $class_name = $ref_type; - $ref_type = $1; - # Some objects would prefer to clone themselves; check for clone_self(). - return $CloneCache{ $source } = $source->$CloneSelfMethod() - if $source->can($CloneSelfMethod); - } - - # To make a copy: - # - Prepare a reference to the same type of structure; - # - Store it in the cache, to avoid looping if it refers to itself; - # - Tie in to the same class as the original, if it was tied; - # - Assign a value to the reference by cloning each item in the original; - - my $copy; - if ($ref_type eq 'HASH') { - $CloneCache{ $source } = $copy = {}; - if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied } - %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source; - } elsif ($ref_type eq 'ARRAY') { - $CloneCache{ $source } = $copy = []; - if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied } - @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source; - } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') { - $CloneCache{ $source } = $copy = \( my $var = "" ); - if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied } - $$copy = clone($$source, $depth); - } else { - # Shallow copy anything else; this handles a reference to code, glob, regex - $CloneCache{ $source } = $copy = $source; - } - - # - Bless it into the same class as the original, if it was blessed; - # - If it has a post-cloning initialization method, call it. - if ( $class_name ) { - bless $copy, $class_name; - $copy->$CloneInitMethod() if $copy->can($CloneInitMethod); - } - - return $copy; -} - -1; - -__END__ - -=head1 NAME - -Clone::PP - Recursively copy Perl datatypes - -=head1 SYNOPSIS - - use Clone::PP qw(clone); - - $item = { 'foo' => 'bar', 'move' => [ 'zig', 'zag' ] }; - $copy = clone( $item ); - - $item = [ 'alpha', 'beta', { 'gamma' => 'vlissides' } ]; - $copy = clone( $item ); - - $item = Foo->new(); - $copy = clone( $item ); - -Or as an object method: - - require Clone::PP; - push @Foo::ISA, 'Clone::PP'; - - $item = Foo->new(); - $copy = $item->clone(); - -=head1 DESCRIPTION - -This module provides a general-purpose clone function to make deep -copies of Perl data structures. It calls itself recursively to copy -nested hash, array, scalar and reference types, including tied -variables and objects. - -The clone() function takes a scalar argument to copy. To duplicate -arrays or hashes, pass them in by reference: - - my $copy = clone(\@array); my @copy = @{ clone(\@array) }; - my $copy = clone(\%hash); my %copy = %{ clone(\%hash) }; - -The clone() function also accepts an optional second parameter that -can be used to limit the depth of the copy. If you pass a limit of -0, clone will return the same value you supplied; for a limit of -1, a shallow copy is constructed; for a limit of 2, two layers of -copying are done, and so on. - - my $shallow_copy = clone( $item, 1 ); - -To allow objects to intervene in the way they are copied, the -clone() function checks for a couple of optional methods. If an -object provides a method named C, it is called and the -result returned without further processing. Alternately, if an -object provides a method named C, it is called on the -copied object before it is returned. - -=head1 BUGS - -Some data types, such as globs, regexes, and code refs, are always copied shallowly. - -References to hash elements are not properly duplicated. (This is why two tests in t/dclone.t that are marked "todo".) For example, the following test should succeed but does not: - - my $hash = { foo => 1 }; - $hash->{bar} = \{ $hash->{foo} }; - my $copy = clone( \%hash ); - $hash->{foo} = 2; - $copy->{foo} = 2; - ok( $hash->{bar} == $copy->{bar} ); - -To report bugs via the CPAN web tracking system, go to -C or send mail -to C, replacing C<#> with C<@>. - -=head1 SEE ALSO - -L - a baseclass which provides a C method. - -L - find-grained cloning for Moose objects. - -The C function in L. - -L - -polymorphic data cloning (see its documentation for what that means). - -L - use whichever of the cloning methods is available. - -=head1 REPOSITORY - -L - -=head1 AUTHOR AND CREDITS - -Developed by Matthew Simon Cavalletto at Evolution Softworks. -More free Perl software is available at C. - - -=head1 COPYRIGHT AND LICENSE - -Copyright 2003 Matthew Simon Cavalletto. You may contact the author -directly at C or C. - -Code initially derived from Ref.pm. Portions Copyright 1994 David Muir Sharnoff. - -Interface based by Clone by Ray Finch with contributions from chocolateboy. -Portions Copyright 2001 Ray Finch. Portions Copyright 2001 chocolateboy. - -You may use, modify, and distribute this software under the same terms as Perl. - -=cut diff --git a/t/lib/Tie/IxHash.pm b/t/lib/Tie/IxHash.pm deleted file mode 100644 index 5b60043..0000000 --- a/t/lib/Tie/IxHash.pm +++ /dev/null @@ -1,651 +0,0 @@ -# -# Tie/IxHash.pm -# -# Indexed hash implementation for Perl -# -# See below for documentation. -# - -require 5.005; - -package Tie::IxHash; -use strict; -use integer; -require Tie::Hash; -use vars qw/@ISA $VERSION/; -@ISA = qw(Tie::Hash); - -$VERSION = $VERSION = '1.23'; - -# -# standard tie functions -# - -sub TIEHASH { - my($c) = shift; - my($s) = []; - $s->[0] = {}; # hashkey index - $s->[1] = []; # array of keys - $s->[2] = []; # array of data - $s->[3] = 0; # iter count - - bless $s, $c; - - $s->Push(@_) if @_; - - return $s; -} - -#sub DESTROY {} # costly if there's nothing to do - -sub FETCH { - my($s, $k) = (shift, shift); - return exists( $s->[0]{$k} ) ? $s->[2][ $s->[0]{$k} ] : undef; -} - -sub STORE { - my($s, $k, $v) = (shift, shift, shift); - - if (exists $s->[0]{$k}) { - my($i) = $s->[0]{$k}; - $s->[1][$i] = $k; - $s->[2][$i] = $v; - $s->[0]{$k} = $i; - } - else { - push(@{$s->[1]}, $k); - push(@{$s->[2]}, $v); - $s->[0]{$k} = $#{$s->[1]}; - } -} - -sub DELETE { - my($s, $k) = (shift, shift); - - if (exists $s->[0]{$k}) { - my($i) = $s->[0]{$k}; - for ($i+1..$#{$s->[1]}) { # reset higher elt indexes - $s->[0]{ $s->[1][$_] }--; # timeconsuming, is there is better way? - } - if ( $i == $s->[3]-1 ) { - $s->[3]--; - } - delete $s->[0]{$k}; - splice @{$s->[1]}, $i, 1; - return (splice(@{$s->[2]}, $i, 1))[0]; - } - return undef; -} - -sub EXISTS { - exists $_[0]->[0]{ $_[1] }; -} - -sub FIRSTKEY { - $_[0][3] = 0; - &NEXTKEY; -} - -sub NEXTKEY { - return $_[0][1][ $_[0][3]++ ] if ($_[0][3] <= $#{ $_[0][1] } ); - return undef; -} - - - -# -# -# class functions that provide additional capabilities -# -# - -sub new { TIEHASH(@_) } - -sub Clear { - my $s = shift; - $s->[0] = {}; # hashkey index - $s->[1] = []; # array of keys - $s->[2] = []; # array of data - $s->[3] = 0; # iter count - return; -} - -# -# add pairs to end of indexed hash -# note that if a supplied key exists, it will not be reordered -# -sub Push { - my($s) = shift; - while (@_) { - $s->STORE(shift, shift); - } - return scalar(@{$s->[1]}); -} - -sub Push2 { - my($s) = shift; - $s->Splice($#{$s->[1]}+1, 0, @_); - return scalar(@{$s->[1]}); -} - -# -# pop last k-v pair -# -sub Pop { - my($s) = shift; - my($k, $v, $i); - $k = pop(@{$s->[1]}); - $v = pop(@{$s->[2]}); - if (defined $k) { - delete $s->[0]{$k}; - return ($k, $v); - } - return undef; -} - -sub Pop2 { - return $_[0]->Splice(-1); -} - -# -# shift -# -sub Shift { - my($s) = shift; - my($k, $v, $i); - $k = shift(@{$s->[1]}); - $v = shift(@{$s->[2]}); - if (defined $k) { - delete $s->[0]{$k}; - for (keys %{$s->[0]}) { - $s->[0]{$_}--; - } - return ($k, $v); - } - return undef; -} - -sub Shift2 { - return $_[0]->Splice(0, 1); -} - -# -# unshift -# if a supplied key exists, it will not be reordered -# -sub Unshift { - my($s) = shift; - my($k, $v, @k, @v, $len, $i); - - while (@_) { - ($k, $v) = (shift, shift); - if (exists $s->[0]{$k}) { - $i = $s->[0]{$k}; - $s->[1][$i] = $k; - $s->[2][$i] = $v; - $s->[0]{$k} = $i; - } - else { - push(@k, $k); - push(@v, $v); - $len++; - } - } - if (defined $len) { - for (keys %{$s->[0]}) { - $s->[0]{$_} += $len; - } - $i = 0; - for (@k) { - $s->[0]{$_} = $i++; - } - unshift(@{$s->[1]}, @k); - return unshift(@{$s->[2]}, @v); - } - return scalar(@{$s->[1]}); -} - -sub Unshift2 { - my($s) = shift; - $s->Splice(0,0,@_); - return scalar(@{$s->[1]}); -} - -# -# splice -# -# any existing hash key order is preserved. the value is replaced for -# such keys, and the new keys are spliced in the regular fashion. -# -# supports -ve offsets but only +ve lengths -# -# always assumes a 0 start offset -# -sub Splice { - my($s, $start, $len) = (shift, shift, shift); - my($k, $v, @k, @v, @r, $i, $siz); - my($end); # inclusive - - # XXX inline this - ($start, $end, $len) = $s->_lrange($start, $len); - - if (defined $start) { - if ($len > 0) { - my(@k) = splice(@{$s->[1]}, $start, $len); - my(@v) = splice(@{$s->[2]}, $start, $len); - while (@k) { - $k = shift(@k); - delete $s->[0]{$k}; - push(@r, $k, shift(@v)); - } - for ($start..$#{$s->[1]}) { - $s->[0]{$s->[1][$_]} -= $len; - } - } - while (@_) { - ($k, $v) = (shift, shift); - if (exists $s->[0]{$k}) { - # $s->STORE($k, $v); - $i = $s->[0]{$k}; - $s->[1][$i] = $k; - $s->[2][$i] = $v; - $s->[0]{$k} = $i; - } - else { - push(@k, $k); - push(@v, $v); - $siz++; - } - } - if (defined $siz) { - for ($start..$#{$s->[1]}) { - $s->[0]{$s->[1][$_]} += $siz; - } - $i = $start; - for (@k) { - $s->[0]{$_} = $i++; - } - splice(@{$s->[1]}, $start, 0, @k); - splice(@{$s->[2]}, $start, 0, @v); - } - } - return @r; -} - -# -# delete elements specified by key -# other elements higher than the one deleted "slide" down -# -sub Delete { - my($s) = shift; - - for (@_) { - # - # XXX potential optimization: could do $s->DELETE only if $#_ < 4. - # otherwise, should reset all the hash indices in one loop - # - $s->DELETE($_); - } -} - -# -# replace hash element at specified index -# -# if the optional key is not supplied the value at index will simply be -# replaced without affecting the order. -# -# if an element with the supplied key already exists, it will be deleted first. -# -# returns the key of replaced value if it succeeds. -# -sub Replace { - my($s) = shift; - my($i, $v, $k) = (shift, shift, shift); - if (defined $i and $i <= $#{$s->[1]} and $i >= 0) { - if (defined $k) { - delete $s->[0]{ $s->[1][$i] }; - $s->DELETE($k) ; #if exists $s->[0]{$k}; - $s->[1][$i] = $k; - $s->[2][$i] = $v; - $s->[0]{$k} = $i; - return $k; - } - else { - $s->[2][$i] = $v; - return $s->[1][$i]; - } - } - return undef; -} - -# -# Given an $start and $len, returns a legal start and end (where start <= end) -# for the current hash. -# Legal range is defined as 0 to $#s+1 -# $len defaults to number of elts upto end of list -# -# 0 1 2 ... -# | X | X | X ... X | X | X | -# -2 -1 (no -0 alas) -# X's above are the elements -# -sub _lrange { - my($s) = shift; - my($offset, $len) = @_; - my($start, $end); # both inclusive - my($size) = $#{$s->[1]}+1; - - return undef unless defined $offset; - if($offset < 0) { - $start = $offset + $size; - $start = 0 if $start < 0; - } - else { - ($offset > $size) ? ($start = $size) : ($start = $offset); - } - - if (defined $len) { - $len = -$len if $len < 0; - $len = $size - $start if $len > $size - $start; - } - else { - $len = $size - $start; - } - $end = $start + $len - 1; - - return ($start, $end, $len); -} - -# -# Return keys at supplied indices -# Returns all keys if no args. -# -sub Keys { - my($s) = shift; - return ( @_ == 1 - ? $s->[1][$_[0]] - : ( @_ - ? @{$s->[1]}[@_] - : @{$s->[1]} ) ); -} - -# -# Returns values at supplied indices -# Returns all values if no args. -# -sub Values { - my($s) = shift; - return ( @_ == 1 - ? $s->[2][$_[0]] - : ( @_ - ? @{$s->[2]}[@_] - : @{$s->[2]} ) ); -} - -# -# get indices of specified hash keys -# -sub Indices { - my($s) = shift; - return ( @_ == 1 ? $s->[0]{$_[0]} : @{$s->[0]}{@_} ); -} - -# -# number of k-v pairs in the ixhash -# note that this does not equal the highest index -# owing to preextended arrays -# -sub Length { - return scalar @{$_[0]->[1]}; -} - -# -# Reorder the hash in the supplied key order -# -# warning: any unsupplied keys will be lost from the hash -# any supplied keys that dont exist in the hash will be ignored -# -sub Reorder { - my($s) = shift; - my(@k, @v, %x, $i); - return unless @_; - - $i = 0; - for (@_) { - if (exists $s->[0]{$_}) { - push(@k, $_); - push(@v, $s->[2][ $s->[0]{$_} ] ); - $x{$_} = $i++; - } - } - $s->[1] = \@k; - $s->[2] = \@v; - $s->[0] = \%x; - return $s; -} - -sub SortByKey { - my($s) = shift; - $s->Reorder(sort $s->Keys); -} - -sub SortByValue { - my($s) = shift; - $s->Reorder(sort { $s->FETCH($a) cmp $s->FETCH($b) } $s->Keys) -} - -1; -__END__ - -=head1 NAME - -Tie::IxHash - ordered associative arrays for Perl - - -=head1 SYNOPSIS - - # simple usage - use Tie::IxHash; - tie HASHVARIABLE, 'Tie::IxHash' [, LIST]; - - # OO interface with more powerful features - use Tie::IxHash; - TIEOBJECT = Tie::IxHash->new( [LIST] ); - TIEOBJECT->Splice( OFFSET [, LENGTH [, LIST]] ); - TIEOBJECT->Push( LIST ); - TIEOBJECT->Pop; - TIEOBJECT->Shift; - TIEOBJECT->Unshift( LIST ); - TIEOBJECT->Keys( [LIST] ); - TIEOBJECT->Values( [LIST] ); - TIEOBJECT->Indices( LIST ); - TIEOBJECT->Delete( [LIST] ); - TIEOBJECT->Replace( OFFSET, VALUE, [KEY] ); - TIEOBJECT->Reorder( LIST ); - TIEOBJECT->SortByKey; - TIEOBJECT->SortByValue; - TIEOBJECT->Length; - - -=head1 DESCRIPTION - -This Perl module implements Perl hashes that preserve the order in which the -hash elements were added. The order is not affected when values -corresponding to existing keys in the IxHash are changed. The elements can -also be set to any arbitrary supplied order. The familiar perl array -operations can also be performed on the IxHash. - - -=head2 Standard C Interface - -The standard C mechanism is available. This interface is -recommended for simple uses, since the usage is exactly the same as -regular Perl hashes after the C is declared. - - -=head2 Object Interface - -This module also provides an extended object-oriented interface that can be -used for more powerful operations with the IxHash. The following methods -are available: - -=over 8 - -=item FETCH, STORE, DELETE, EXISTS - -These standard C methods mandated by Perl can be used directly. -See the C entry in perlfunc(1) for details. - -=item Push, Pop, Shift, Unshift, Splice - -These additional methods resembling Perl functions are available for -operating on key-value pairs in the IxHash. The behavior is the same as the -corresponding perl functions, except when a supplied hash key already exists -in the hash. In that case, the existing value is updated but its order is -not affected. To unconditionally alter the order of a supplied key-value -pair, first C the IxHash element. - -=item Keys - -Returns an array of IxHash element keys corresponding to the list of supplied -indices. Returns an array of all the keys if called without arguments. -Note the return value is mostly only useful when used in a list context -(since perl will convert it to the number of elements in the array when -used in a scalar context, and that may not be very useful). - -If a single argument is given, returns the single key corresponding to -the index. This is usable in either scalar or list context. - -=item Values - -Returns an array of IxHash element values corresponding to the list of supplied -indices. Returns an array of all the values if called without arguments. -Note the return value is mostly only useful when used in a list context -(since perl will convert it to the number of elements in the array when -used in a scalar context, and that may not be very useful). - -If a single argument is given, returns the single value corresponding to -the index. This is usable in either scalar or list context. - -=item Indices - -Returns an array of indices corresponding to the supplied list of keys. -Note the return value is mostly only useful when used in a list context -(since perl will convert it to the number of elements in the array when -used in a scalar context, and that may not be very useful). - -If a single argument is given, returns the single index corresponding to -the key. This is usable in either scalar or list context. - -=item Delete - -Removes elements with the supplied keys from the IxHash. - -=item Replace - -Substitutes the IxHash element at the specified index with the supplied -value-key pair. If a key is not supplied, simply substitutes the value at -index with the supplied value. If an element with the supplied key already -exists, it will be removed from the IxHash first. - -=item Reorder - -This method can be used to manipulate the internal order of the IxHash -elements by supplying a list of keys in the desired order. Note however, -that any IxHash elements whose keys are not in the list will be removed from -the IxHash. - -=item Length - -Returns the number of IxHash elements. - -=item SortByKey - -Reorders the IxHash elements by textual comparison of the keys. - -=item SortByValue - -Reorders the IxHash elements by textual comparison of the values. - -=item Clear - -Resets the IxHash to its pristine state: with no elements at all. - -=back - - -=head1 EXAMPLE - - use Tie::IxHash; - - # simple interface - $t = tie(%myhash, 'Tie::IxHash', 'a' => 1, 'b' => 2); - %myhash = (first => 1, second => 2, third => 3); - $myhash{fourth} = 4; - @keys = keys %myhash; - @values = values %myhash; - print("y") if exists $myhash{third}; - - # OO interface - $t = Tie::IxHash->new(first => 1, second => 2, third => 3); - $t->Push(fourth => 4); # same as $myhash{'fourth'} = 4; - ($k, $v) = $t->Pop; # $k is 'fourth', $v is 4 - $t->Unshift(neg => -1, zeroth => 0); - ($k, $v) = $t->Shift; # $k is 'neg', $v is -1 - @oneandtwo = $t->Splice(1, 2, foo => 100, bar => 101); - - @keys = $t->Keys; - @values = $t->Values; - @indices = $t->Indices('foo', 'zeroth'); - @itemkeys = $t->Keys(@indices); - @itemvals = $t->Values(@indices); - $t->Replace(2, 0.3, 'other'); - $t->Delete('second', 'zeroth'); - $len = $t->Length; # number of key-value pairs - - $t->Reorder(reverse @keys); - $t->SortByKey; - $t->SortByValue; - - -=head1 BUGS - -You cannot specify a negative length to C. Negative indexes are OK, -though. - - -=head1 NOTE - -Indexing always begins at 0 (despite the current C<$[> setting) for -all the functions. - - -=head1 TODO - -Addition of elements with keys that already exist to the end of the IxHash -must be controlled by a switch. - -Provide C interface when it stabilizes in Perl. - -Rewrite using XSUBs for efficiency. - - -=head1 AUTHOR - -Gurusamy Sarathy gsar@umich.edu - -Copyright (c) 1995 Gurusamy Sarathy. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - - -=head1 VERSION - -Version 1.23 - - -=head1 SEE ALSO - -perl(1) - -=cut From cae68ff4f77611378f85ffe1212d9bba8f9622ce Mon Sep 17 00:00:00 2001 From: Keita Jamadam Sugama Date: Fri, 19 Sep 2025 18:31:31 +0900 Subject: [PATCH 26/26] rename bind concatinated flat --- lib/Data/ObjectDriver/SQL.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Data/ObjectDriver/SQL.pm b/lib/Data/ObjectDriver/SQL.pm index b63dce0..c37576f 100644 --- a/lib/Data/ObjectDriver/SQL.pm +++ b/lib/Data/ObjectDriver/SQL.pm @@ -11,7 +11,7 @@ __PACKAGE__->mk_accessors(qw( select distinct select_map select_map_reverse from joins where bind limit offset group order having where_values column_mutator index_hint - comment as aggrigated + comment as is_bind_contatinated )); sub new { @@ -139,9 +139,9 @@ sub as_sql { $sql .= "-- $1" if $1; } - unless ($stmt->aggrigated) { + unless ($stmt->is_bind_contatinated) { @{ $stmt->{bind} } = (@bind_for_select, @bind_for_from, @{ $stmt->{bind} }); - $stmt->aggrigated(1); + $stmt->is_bind_contatinated(1); } return $sql;