[SCM] Debian packaging of libdbix-searchbuilder-perl branch, master, updated. debian/1.61-1
Ansgar Burchardt
ansgar at debian.org
Wed Sep 21 17:13:57 UTC 2011
The following commit has been merged in the master branch:
commit 46bcb4516d2d5c939d34454ac86e405a51731fb4
Author: Ansgar Burchardt <ansgar at debian.org>
Date: Wed Sep 21 18:46:40 2011 +0200
Imported Upstream version 1.61
diff --git a/Changes b/Changes
index 10f62dc..69c8134 100755
--- a/Changes
+++ b/Changes
@@ -1,5 +1,21 @@
Revision history for Perl extension DBIx::SearchBuilder.
+1.61 Fri Sep 16 15:47:50 MSD 2011
+
+* New methods in Handle for mass changes from select statements:
+ InsertFromSelect, DeleteFromSelect and SimpleUpdateFromSelect
+* New methods in Handle for generation of date time related SQL
+
+1.60 Thu Sep 15 01:01:15 MSD 2011
+
+* custom BuildDSN for Oracle
+** Database is treated as SID if SID is not provided
+** Build 'dbi:Oracle:<SID>' instead of 'dbi:Oracle:sid=<SID>'
+* changes in DBIx::SearchBuilder->Column method
+** complete documentation
+** support for empty FIELD argument
+** column naming fix when explicit ALIAS => 'main' passed
+
1.59 Fri Nov 19 13:45:01 MSK 2010
* DBIx::SearchBuilder->DistinctFieldValues method
diff --git a/MANIFEST b/MANIFEST
index 406bde8..44fbeb1 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -7,29 +7,33 @@ inc/Module/AutoInstall.pm
inc/Module/Install.pm
inc/Module/Install/AutoInstall.pm
inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
inc/Module/Install/Include.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/DBIx/SearchBuilder.pm
+lib/DBIx/SearchBuilder/Handle.pm
+lib/DBIx/SearchBuilder/Handle/Informix.pm
+lib/DBIx/SearchBuilder/Handle/mysql.pm
+lib/DBIx/SearchBuilder/Handle/mysqlPP.pm
+lib/DBIx/SearchBuilder/Handle/ODBC.pm
+lib/DBIx/SearchBuilder/Handle/Oracle.pm
+lib/DBIx/SearchBuilder/Handle/Pg.pm
+lib/DBIx/SearchBuilder/Handle/SQLite.pm
+lib/DBIx/SearchBuilder/Handle/Sybase.pm
+lib/DBIx/SearchBuilder/Record.pm
+lib/DBIx/SearchBuilder/Record/Cachable.pm
+lib/DBIx/SearchBuilder/SchemaGenerator.pm
+lib/DBIx/SearchBuilder/Union.pm
+lib/DBIx/SearchBuilder/Unique.pm
Makefile.PL
MANIFEST This list of files
META.yml
README
ROADMAP
-SearchBuilder.pm
-SearchBuilder/Handle.pm
-SearchBuilder/Handle/Informix.pm
-SearchBuilder/Handle/mysql.pm
-SearchBuilder/Handle/mysqlPP.pm
-SearchBuilder/Handle/ODBC.pm
-SearchBuilder/Handle/Oracle.pm
-SearchBuilder/Handle/Pg.pm
-SearchBuilder/Handle/SQLite.pm
-SearchBuilder/Handle/Sybase.pm
-SearchBuilder/Record.pm
-SearchBuilder/Record/Cachable.pm
-SearchBuilder/SchemaGenerator.pm
-SearchBuilder/Union.pm
-SearchBuilder/Unique.pm
SIGNATURE
t/00.load.t
t/01basics.t
@@ -39,9 +43,12 @@ t/01searches.t
t/02distinct_values.t
t/02order_outer.t
t/02records_cachable.t
+t/02records_datetime.t
t/02records_integers.t
t/02records_object.t
t/02searches_joins.t
+t/03compatibility.t
+t/03cud_from_select.t
t/03rebless.t
t/03transactions.t
t/03versions.t
diff --git a/META.yml b/META.yml
index 999a456..8865ae5 100644
--- a/META.yml
+++ b/META.yml
@@ -10,7 +10,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 1.00'
+generated_by: 'Module::Install version 1.01'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -30,6 +30,7 @@ requires:
DBIx::DBSchema: 0
Encode: 1.99
Want: 0
+ capitalization: 0.03
resources:
license: http://dev.perl.org/licenses/
-version: 1.59
+version: 1.61
diff --git a/Makefile.PL b/Makefile.PL
index 04ba503..6fb6617 100755
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -3,7 +3,7 @@ use inc::Module::Install;
name ('DBIx-SearchBuilder');
license ('perl');
author ('Jesse Vincent <jesse at bestpractical.com>');
-all_from('SearchBuilder.pm');
+all_from('lib/DBIx/SearchBuilder.pm');
requires('DBI');
requires('Want');
requires('Encode' => '1.99');
@@ -29,5 +29,4 @@ auto_install();
no_index directory => 't';
no_index directory => 'ex';
-&Makefile->write;
-&Meta->write;
+WriteAll();
diff --git a/SIGNATURE b/SIGNATURE
index e3bc841..ce2c0f8 100644
--- a/SIGNATURE
+++ b/SIGNATURE
@@ -15,48 +15,55 @@ not run its Makefile.PL or Build.PL.
Hash: SHA1
SHA1 1176bc1e043a0f1f11333fc4c64a5bc7e3cd4f77 .gitignore
-SHA1 94f49ca2a2e285c55b274c8897b34740cf1a5d8f Changes
-SHA1 65ec70d561d3269c548a6eeacfe832d5cbfc0d76 MANIFEST
-SHA1 f6e20473637ec59824c5e1af98e0f540e1787b65 META.yml
-SHA1 7f3870fd1159dc9ad4c1666a58d89feb0cbfae3a Makefile.PL
+SHA1 b00064d6acc0296a0eb935f11b96acf9fa56160a Changes
+SHA1 db96fa6342b9c945275b135aa6377b8c612ee028 MANIFEST
+SHA1 e8aa9b81ca522cffee29a8844c13ba173d8f7e0c META.yml
+SHA1 70e01b4bbd8acc02b399160d5ec023a1606e862e Makefile.PL
SHA1 d7a41642c368f2a587587e09f9e815d434feebff README
SHA1 5a53d12d5cccd94845a6a7cc105cd9be34e20f1c ROADMAP
-SHA1 da33893e5ddba27d4456a9aeb467fa92aafd45c9 SearchBuilder.pm
-SHA1 edd0342c7b45c8b10e4a04caf60d80454b537261 SearchBuilder/Handle.pm
-SHA1 55d337e6dd1ab5aecc39d2ae491bffb12e9ca449 SearchBuilder/Handle/Informix.pm
-SHA1 4efdcaefa5f94d994b052d1b343d2f5164ef4b52 SearchBuilder/Handle/ODBC.pm
-SHA1 ece5517d11f5b5f7f69606f6d2af6ee607fd5aef SearchBuilder/Handle/Oracle.pm
-SHA1 e0a5ca9e65c4c66237871fdede804327626e6259 SearchBuilder/Handle/Pg.pm
-SHA1 33300f29f601f259cd483e7cba69938bc133f833 SearchBuilder/Handle/SQLite.pm
-SHA1 ec3fbc03b27c008d93a52b6b7fb0076529e5fcc8 SearchBuilder/Handle/Sybase.pm
-SHA1 1ca13e69a8f02944469f448e72604e5cc9dad162 SearchBuilder/Handle/mysql.pm
-SHA1 877685aaff265e36fa37298c372aa56864f68aa5 SearchBuilder/Handle/mysqlPP.pm
-SHA1 0354afcfa375ec89e67953c933ceb958235039f6 SearchBuilder/Record.pm
-SHA1 145046df9fcea187d59493a02c62c578fcf75599 SearchBuilder/Record/Cachable.pm
-SHA1 a15065e472797e2bfe8149f04d3bdc58f67a7a6d SearchBuilder/SchemaGenerator.pm
-SHA1 f59ad14464f1520aa4f9dacdf437047081a94741 SearchBuilder/Union.pm
-SHA1 1eb4e838ff1d8d927bfe177bf578df246802b03d SearchBuilder/Unique.pm
SHA1 e7c7c7c91025072d25da78c93cefa2bc0aaf2b35 ex/Example/Model/Address.pm
SHA1 f821661849153c21ad99393b6a3ea6720fdaf581 ex/Example/Model/Employee.pm
SHA1 9689368197327e7b38af7f3d1f863e918ed4fa98 ex/create_tables.pl
SHA1 20c73697e1713638140c719d8eaa19a275ed43a5 inc/Module/AutoInstall.pm
-SHA1 7305dbe2904416e28decb05396988a5d51d578be inc/Module/Install.pm
-SHA1 ca13d9875e1249f6e84f7070be8152c34837955e inc/Module/Install/AutoInstall.pm
-SHA1 129960509127732258570c122042bc48615222e1 inc/Module/Install/Base.pm
-SHA1 b501b0df59a5cd235cca473889f82c3d3429f39e inc/Module/Install/Include.pm
-SHA1 b721c93ca5bc9a6aa863b49af15f1b1de6125935 inc/Module/Install/Makefile.pm
-SHA1 026cc0551a0ad399d195e395b46bdf842e115192 inc/Module/Install/Metadata.pm
-SHA1 e59ea21b9407644714a5f67c7132a11916c25133 t/00.load.t
+SHA1 7b4ae50ebac72d20761171c4c2b50c206344ea40 inc/Module/Install.pm
+SHA1 c3cb159acd7618ea662f28deb0d0bf8f24742ebb inc/Module/Install/AutoInstall.pm
+SHA1 d9fe55a427fe2fd75b5029afeeaa61b592e07f79 inc/Module/Install/Base.pm
+SHA1 62d3922826d9f89f20c185e7031ac8f028504745 inc/Module/Install/Can.pm
+SHA1 dc809f64fb70a26b069a36f8d3d353d520dbb7e1 inc/Module/Install/Fetch.pm
+SHA1 d859f2d8048708f16b5fd92f54c988a3c4c1ae30 inc/Module/Install/Include.pm
+SHA1 73ab91490a628452cc140db72ef9d13a1326d211 inc/Module/Install/Makefile.pm
+SHA1 8ce3f2b414e4617e6233dd4ba10830f8c5d672ec inc/Module/Install/Metadata.pm
+SHA1 3b0acd2eeac93a0afe48120f5648f0db362e5bbf inc/Module/Install/Win32.pm
+SHA1 f08924f051e623f8e09fa6a121993c4a9cf7d9eb inc/Module/Install/WriteAll.pm
+SHA1 5744b22b3621931e9d6db6f72a2d952c769368ec lib/DBIx/SearchBuilder.pm
+SHA1 2798003c8e38ac934359f328e4e92c6225b57a0e lib/DBIx/SearchBuilder/Handle.pm
+SHA1 55d337e6dd1ab5aecc39d2ae491bffb12e9ca449 lib/DBIx/SearchBuilder/Handle/Informix.pm
+SHA1 4efdcaefa5f94d994b052d1b343d2f5164ef4b52 lib/DBIx/SearchBuilder/Handle/ODBC.pm
+SHA1 18f621fc6c2e16d7a5b8576487924107d4725968 lib/DBIx/SearchBuilder/Handle/Oracle.pm
+SHA1 dd8b0e7fce82da74d78b9bc384c33882aa2e0d38 lib/DBIx/SearchBuilder/Handle/Pg.pm
+SHA1 6c2cfe7a59e501c2378590ea29f0fb2c5057f2f0 lib/DBIx/SearchBuilder/Handle/SQLite.pm
+SHA1 ec3fbc03b27c008d93a52b6b7fb0076529e5fcc8 lib/DBIx/SearchBuilder/Handle/Sybase.pm
+SHA1 d672a0e4c5458d0e2b5216ece7ea0cdce08a1989 lib/DBIx/SearchBuilder/Handle/mysql.pm
+SHA1 877685aaff265e36fa37298c372aa56864f68aa5 lib/DBIx/SearchBuilder/Handle/mysqlPP.pm
+SHA1 b7523cc56eebe1e0f0840bda00bb6c3c8422585c lib/DBIx/SearchBuilder/Record.pm
+SHA1 145046df9fcea187d59493a02c62c578fcf75599 lib/DBIx/SearchBuilder/Record/Cachable.pm
+SHA1 a15065e472797e2bfe8149f04d3bdc58f67a7a6d lib/DBIx/SearchBuilder/SchemaGenerator.pm
+SHA1 f59ad14464f1520aa4f9dacdf437047081a94741 lib/DBIx/SearchBuilder/Union.pm
+SHA1 1eb4e838ff1d8d927bfe177bf578df246802b03d lib/DBIx/SearchBuilder/Unique.pm
+SHA1 b7c82b550346f85678591966871bd47d6775bb70 t/00.load.t
SHA1 a7ed1ee359ebe2842b354b5652a441403e802080 t/01basics.t
SHA1 2b2dc6f72370f60e1d233f2f8c12bb87414e825c t/01nocap_api.t
SHA1 982a982a0e48bea88cb48cea46765e6271c508ed t/01records.t
-SHA1 d3a35118e7e04e2e8bd9d90b2ed01edb563ab829 t/01searches.t
-SHA1 74e758cce9a32fa84d0161d961c20d1d8e01a287 t/02distinct_values.t
+SHA1 18460596f6597ed0cf4134e6a47925368b819dbe t/01searches.t
+SHA1 764771341b46b2da833ee2ddaa5c4d3191619e89 t/02distinct_values.t
SHA1 af1f5d616e935cd955c2fb55c9595c8d35a3922c t/02order_outer.t
SHA1 67d4c0dca9d1914eadba64460f3a2da4e074ae14 t/02records_cachable.t
+SHA1 f4ef4abcab341b22782b0ca88eb69f276de861fa t/02records_datetime.t
SHA1 e791bc2dc9ebcfe194f00eb9d0d61c391200b589 t/02records_integers.t
SHA1 6e50e77f1b54fe28fd6bcbb6eb104527f25d2601 t/02records_object.t
SHA1 1398226c92dac259a3178e273b6674e45df8225e t/02searches_joins.t
+SHA1 277100711a9adc634e2db7bc3701c7a927d689dc t/03compatibility.t
+SHA1 b0b0107a86e46f50c4a03341274857e58be9e372 t/03cud_from_select.t
SHA1 fdc1ebd0353a4483f9a64a1b6558fd8c22b6a0e4 t/03rebless.t
SHA1 0832f29ca227de8b962b74788e1e1637dc110ddc t/03transactions.t
SHA1 1fe8ef579aa7e503f3227d42674c2218e4400ab5 t/03versions.t
@@ -68,7 +75,7 @@ SHA1 ceb2fad4e6973b7b30f0e83abc14cfb80ac93efe t/utils.pl
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.11 (Darwin)
-iEYEARECAAYFAkzmVb4ACgkQvH6dkeDZaS86RACfX8TiwCVJr7fElS1Ar+JR3vNV
-vG0An34HlLrpietryryRnzwwZ5/mR8ij
-=oHD1
+iEYEARECAAYFAk5zN1UACgkQvH6dkeDZaS9NLwCfcCyEQNZj8xriF9v5wuJ23Ne3
+P9YAn19tUo9CklJpOGYooA2L1u8hTQDZ
+=dxHi
-----END PGP SIGNATURE-----
diff --git a/SearchBuilder/Handle/mysql.pm b/SearchBuilder/Handle/mysql.pm
deleted file mode 100755
index efaac1a..0000000
--- a/SearchBuilder/Handle/mysql.pm
+++ /dev/null
@@ -1,154 +0,0 @@
-# $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/mysql.pm,v 1.8 2001/10/12 05:27:05 jesse Exp $
-
-package DBIx::SearchBuilder::Handle::mysql;
-
-use strict;
-use warnings;
-
-use base qw(DBIx::SearchBuilder::Handle);
-
-=head1 NAME
-
- DBIx::SearchBuilder::Handle::mysql - A mysql specific Handle object
-
-=head1 SYNOPSIS
-
-
-=head1 DESCRIPTION
-
-This module provides a subclass of DBIx::SearchBuilder::Handle that
-compensates for some of the idiosyncrasies of MySQL.
-
-=head1 METHODS
-
-=head2 Insert
-
-Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted.
-
-If the insert succeeds, returns the id of the insert, otherwise, returns
-a Class::ReturnValue object with the error reported.
-
-=cut
-
-sub Insert {
- my $self = shift;
-
- my $sth = $self->SUPER::Insert(@_);
- if (!$sth) {
- return ($sth);
- }
-
- $self->{'id'}=$self->dbh->{'mysql_insertid'};
-
- # Yay. we get to work around mysql_insertid being null some of the time :/
- unless ($self->{'id'}) {
- $self->{'id'} = $self->FetchResult('SELECT LAST_INSERT_ID()');
- }
- warn "$self no row id returned on row creation" unless ($self->{'id'});
-
- return( $self->{'id'}); #Add Succeded. return the id
- }
-
-
-
-=head2 DatabaseVersion
-
-Returns the mysql version, trimming off any -foo identifier
-
-=cut
-
-sub DatabaseVersion {
- my $self = shift;
- my $v = $self->SUPER::DatabaseVersion();
-
- $v =~ s/\-.*$//;
- return ($v);
-}
-
-=head2 CaseSensitive
-
-Returns undef, since mysql's searches are not case sensitive by default
-
-=cut
-
-sub CaseSensitive {
- my $self = shift;
- return(undef);
-}
-
-sub DistinctQuery {
- my $self = shift;
- my $statementref = shift;
- my $sb = shift;
-
- return $self->SUPER::DistinctQuery( $statementref, $sb, @_ )
- if $sb->_OrderClause !~ /(?<!main)\./;
-
- if ( substr($self->DatabaseVersion, 0, 1) == 4 ) {
- local $sb->{'group_by'} = [{FIELD => 'id'}];
-
- my ($idx, @tmp, @specials) = (0, ());
- foreach ( @{$sb->{'order_by'}} ) {
- if ( !exists $_->{'ALIAS'} || ($_->{'ALIAS'}||'') eq "main" ) {
- push @tmp, $_; next;
- }
-
- push @specials,
- ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN')
- ."(". $_->{'ALIAS'} .".". $_->{'FIELD'} .")"
- ." __special_sort_$idx";
- push @tmp, { ALIAS => '', FIELD => "__special_sort_$idx", ORDER => $_->{'ORDER'} };
- $idx++;
- }
-
- local $sb->{'order_by'} = \@tmp;
- $$statementref = "SELECT ". join( ", ", 'main.*', @specials ) ." FROM $$statementref";
- $$statementref .= $sb->_GroupClause;
- $$statementref .= $sb->_OrderClause;
- } else {
- local $sb->{'group_by'} = [{FIELD => 'id'}];
- local $sb->{'order_by'} = [
- map {
- ($_->{'ALIAS'}||'') ne "main"
- ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" }
- : $_
- }
- @{$sb->{'order_by'}}
- ];
- $$statementref = "SELECT main.* FROM $$statementref";
- $$statementref .= $sb->_GroupClause;
- $$statementref .= $sb->_OrderClause;
- }
-}
-
-sub Fields {
- my $self = shift;
- my $table = shift;
-
- my $cache = \%DBIx::SearchBuilder::Handle::FIELDS_IN_TABLE;
- unless ( $cache->{ lc $table } ) {
- my $sth = $self->dbh->column_info( undef, undef, $table, '%' )
- or return ();
- my $info = $sth->fetchall_arrayref({});
- foreach my $e ( sort {$a->{'ORDINAL_POSITION'} <=> $b->{'ORDINAL_POSITION'}} @$info ) {
- push @{ $cache->{ lc $e->{'TABLE_NAME'} } ||= [] }, lc $e->{'COLUMN_NAME'};
- }
- }
- return @{ $cache->{ lc $table } || [] };
-}
-
-
-1;
-
-__END__
-
-=head1 AUTHOR
-
-Jesse Vincent, jesse at fsck.com
-
-=head1 SEE ALSO
-
-DBIx::SearchBuilder, DBIx::SearchBuilder::Handle
-
-=cut
-
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 8ee839d..74caf9c 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -31,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '1.00';
+ $VERSION = '1.01';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -467,4 +467,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2010 Adam Kennedy.
+# Copyright 2008 - 2011 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index f1f5356..bc3d172 100644
--- a/inc/Module/Install/AutoInstall.pm
+++ b/inc/Module/Install/AutoInstall.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index b55bda3..d3662c9 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
}
# Suspend handler for "redefined" warnings
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
new file mode 100644
index 0000000..276409a
--- /dev/null
+++ b/inc/Module/Install/Can.pm
@@ -0,0 +1,81 @@
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Config ();
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.01';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+# check if we can load some module
+### Upgrade this to not have to load the module if possible
+sub can_use {
+ my ($self, $mod, $ver) = @_;
+ $mod =~ s{::|\\}{/}g;
+ $mod .= '.pm' unless $mod =~ /\.pm$/i;
+
+ my $pkg = $mod;
+ $pkg =~ s{/}{::}g;
+ $pkg =~ s{\.pm$}{}i;
+
+ local $@;
+ eval { require $mod; $pkg->VERSION($ver || 0); 1 };
+}
+
+# check if we can run some command
+sub can_run {
+ my ($self, $cmd) = @_;
+
+ my $_cmd = $cmd;
+ return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+
+ for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ next if $dir eq '';
+ my $abs = File::Spec->catfile($dir, $_[1]);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+# can we locate a (the) C compiler
+sub can_cc {
+ my $self = shift;
+ my @chunks = split(/ /, $Config::Config{cc}) or return;
+
+ # $Config{cc} may contain args; try to find out the program part
+ while (@chunks) {
+ return $self->can_run("@chunks") || (pop(@chunks), next);
+ }
+
+ return;
+}
+
+# Fix Cygwin bug on maybe_command();
+if ( $^O eq 'cygwin' ) {
+ require ExtUtils::MM_Cygwin;
+ require ExtUtils::MM_Win32;
+ if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
+ *ExtUtils::MM_Cygwin::maybe_command = sub {
+ my ($self, $file) = @_;
+ if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
+ ExtUtils::MM_Win32->maybe_command($file);
+ } else {
+ ExtUtils::MM_Unix->maybe_command($file);
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+#line 156
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
new file mode 100644
index 0000000..093cb7a
--- /dev/null
+++ b/inc/Module/Install/Fetch.pm
@@ -0,0 +1,93 @@
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.01';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+sub get_file {
+ my ($self, %args) = @_;
+ my ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+
+ if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
+ $args{url} = $args{ftp_url}
+ or (warn("LWP support unavailable!\n"), return);
+ ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+ }
+
+ $|++;
+ print "Fetching '$file' from $host... ";
+
+ unless (eval { require Socket; Socket::inet_aton($host) }) {
+ warn "'$host' resolve failed!\n";
+ return;
+ }
+
+ return unless $scheme eq 'ftp' or $scheme eq 'http';
+
+ require Cwd;
+ my $dir = Cwd::getcwd();
+ chdir $args{local_dir} or return if exists $args{local_dir};
+
+ if (eval { require LWP::Simple; 1 }) {
+ LWP::Simple::mirror($args{url}, $file);
+ }
+ elsif (eval { require Net::FTP; 1 }) { eval {
+ # use Net::FTP to get past firewall
+ my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
+ $ftp->login("anonymous", 'anonymous at example.com');
+ $ftp->cwd($path);
+ $ftp->binary;
+ $ftp->get($file) or (warn("$!\n"), return);
+ $ftp->quit;
+ } }
+ elsif (my $ftp = $self->can_run('ftp')) { eval {
+ # no Net::FTP, fallback to ftp.exe
+ require FileHandle;
+ my $fh = FileHandle->new;
+
+ local $SIG{CHLD} = 'IGNORE';
+ unless ($fh->open("|$ftp -n")) {
+ warn "Couldn't open ftp: $!\n";
+ chdir $dir; return;
+ }
+
+ my @dialog = split(/\n/, <<"END_FTP");
+open $host
+user anonymous anonymous\@example.com
+cd $path
+binary
+get $file $file
+quit
+END_FTP
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close;
+ } }
+ else {
+ warn "No working 'ftp' program available!\n";
+ chdir $dir; return;
+ }
+
+ unless (-f $file) {
+ warn "Fetching failed: $@\n";
+ chdir $dir; return;
+ }
+
+ return if exists $args{size} and -s $file != $args{size};
+ system($args{run}) if exists $args{run};
+ unlink($file) if $args{remove};
+
+ print(((!exists $args{check_for} or -e $args{check_for})
+ ? "done!" : "failed! ($!)"), "\n");
+ chdir $dir; return !$?;
+}
+
+1;
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index a28cd4c..90cc979 100644
--- a/inc/Module/Install/Include.pm
+++ b/inc/Module/Install/Include.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 5dfd0e9..4c71003 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index cfe45b3..3b01e09 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.00';
+ $VERSION = '1.01';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -515,6 +515,7 @@ sub __extract_license {
'GNU Free Documentation license' => 'unrestricted', 1,
'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
+ 'Artistic license 2\.0' => 'artistic_2', 1,
'Artistic license' => 'artistic', 1,
'Apache (?:Software )?license' => 'apache', 1,
'GPL' => 'gpl', 1,
@@ -550,9 +551,9 @@ sub license_from {
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(
- \Qhttp://rt.cpan.org/\E[^>]+|
- \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
- \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
+ https?\Q://rt.cpan.org/\E[^>]+|
+ https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
+ https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
)>#gx;
my %links;
@links{@links}=();
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
new file mode 100644
index 0000000..3139a63
--- /dev/null
+++ b/inc/Module/Install/Win32.pm
@@ -0,0 +1,64 @@
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.01';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+# determine if the user needs nmake, and download it if needed
+sub check_nmake {
+ my $self = shift;
+ $self->load('can_run');
+ $self->load('get_file');
+
+ require Config;
+ return unless (
+ $^O eq 'MSWin32' and
+ $Config::Config{make} and
+ $Config::Config{make} =~ /^nmake\b/i and
+ ! $self->can_run('nmake')
+ );
+
+ print "The required 'nmake' executable not found, fetching it...\n";
+
+ require File::Basename;
+ my $rv = $self->get_file(
+ url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
+ ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
+ local_dir => File::Basename::dirname($^X),
+ size => 51928,
+ run => 'Nmake15.exe /o > nul',
+ check_for => 'Nmake.exe',
+ remove => 1,
+ );
+
+ die <<'END_MESSAGE' unless $rv;
+
+-------------------------------------------------------------------------------
+
+Since you are using Microsoft Windows, you will need the 'nmake' utility
+before installation. It's available at:
+
+ http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
+ or
+ ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
+
+Please download the file manually, save it to a directory in %PATH% (e.g.
+C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
+that directory, and run "Nmake15.exe" from there; that will create the
+'nmake.exe' file needed by this module.
+
+You may then resume the installation process described in README.
+
+-------------------------------------------------------------------------------
+END_MESSAGE
+
+}
+
+1;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
new file mode 100644
index 0000000..1f724a7
--- /dev/null
+++ b/inc/Module/Install/WriteAll.pm
@@ -0,0 +1,63 @@
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.01';
+ @ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
+}
+
+sub WriteAll {
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_,
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{PL_FILES} ) {
+ # XXX: This still may be a bit over-defensive...
+ unless ($self->makemaker(6.25)) {
+ $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
+ }
+ }
+
+ # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
+ # we clean it up properly ourself.
+ $self->realclean_files('MYMETA.yml');
+
+ if ( $args{inline} ) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
+
+ # The Makefile write process adds a couple of dependencies,
+ # so write the META.yml files after the Makefile.
+ if ( $args{meta} ) {
+ $self->Meta->write;
+ }
+
+ # Experimental support for MYMETA
+ if ( $ENV{X_MYMETA} ) {
+ if ( $ENV{X_MYMETA} eq 'JSON' ) {
+ $self->Meta->write_mymeta_json;
+ } else {
+ $self->Meta->write_mymeta_yaml;
+ }
+ }
+
+ return 1;
+}
+
+1;
diff --git a/SearchBuilder.pm b/lib/DBIx/SearchBuilder.pm
similarity index 93%
rename from SearchBuilder.pm
rename to lib/DBIx/SearchBuilder.pm
index b7e01e0..0ad6e77 100755
--- a/SearchBuilder.pm
+++ b/lib/DBIx/SearchBuilder.pm
@@ -4,7 +4,7 @@ package DBIx::SearchBuilder;
use strict;
use warnings;
-our $VERSION = "1.59";
+our $VERSION = "1.61";
use Clone qw();
use Encode qw();
@@ -841,11 +841,7 @@ sub Limit {
# we're doing an IS or IS NOT (null), don't quote the operator.
if ( $args{'QUOTEVALUE'} && $args{'OPERATOR'} !~ /IS/i ) {
- my $turn_utf = Encode::is_utf8( $args{'VALUE'} );
$args{'VALUE'} = $self->_Handle->dbh->quote( $args{'VALUE'} );
-
- # Accomodate DBI drivers that don't understand UTF8
- Encode::_utf8_on( $args{'VALUE'} ) if $turn_utf;
}
}
@@ -1501,13 +1497,66 @@ sub IsLast {
}
-=head2 Column { FIELD => undef }
+=head2 Column
+
+Call to specify which columns should be loaded from the table. Each
+calls adds one column to the set. Takes a hash with the following named
+arguments:
+
+=over 4
+
+=item FIELD
+
+Column name to fetch or apply function to. This can be omitted if a
+FUNCTION is given which is not a function of a field.
+
+=item ALIAS
+
+Alias of a table the field is in; defaults to C<main>
+
+=item FUNCTION
+
+A SQL function that should be selected as the result. If a FIELD is
+provided, then it is inserted into the function according to the
+following rules:
+
+=over 4
+
+=item *
+
+If the text of the function contains a '?' (question mark), then it is
+replaced with qualified FIELD.
+
+=item *
+
+If the text of the function has no '(' (opening parenthesis), then the
+qualified FIELD is appended in parentheses to the text.
+
+=item *
+
+Otherwise, the function is inserted verbatim, with no substitution.
-Specify that we want to load the column FIELD.
+=back
+
+=back
+
+If a FIELD is provided and it is in this table (ALIAS is 'main'), then
+the column named FIELD and can be accessed as usual by accessors:
+
+ $articles->Column(FIELD => 'id');
+ $articles->Column(FIELD => 'Subject', FUNCTION => 'SUBSTR(?, 1, 20)');
+ my $article = $articles->First;
+ my $aid = $article->id;
+ my $subject_prefix = $article->Subject;
-Other parameters are TABLE ALIAS AND FUNCTION.
+Returns the alias used for the column. If FIELD was not provided, or was
+from another table, then the returned column alias should be passed to
+the L<DBIx::SearchBuilder::Record/_Value> method to retrieve the
+column's result:
-Autrijus and Ruslan owe docs.
+ my $time_alias = $articles->Column(FUNCTION => 'NOW()');
+ my $article = $articles->First;
+ my $now = $article->_Value( $time_alias );
=cut
@@ -1519,24 +1568,19 @@ sub Column {
FUNCTION => undef,
@_);
- my $table = $args{TABLE} || do {
- if ( my $alias = $args{ALIAS} ) {
- $alias =~ s/_\d+$//;
- $alias;
- }
- else {
- $self->Table;
- }
- };
+ $args{'ALIAS'} ||= 'main';
+
+ my $name;
+ if ( $args{FIELD} && $args{FUNCTION} ) {
+ $name = $args{'ALIAS'} .'.'. $args{'FIELD'};
- my $name = ( $args{ALIAS} || 'main' ) . '.' . $args{FIELD};
- if ( my $func = $args{FUNCTION} ) {
+ my $func = $args{FUNCTION};
if ( $func =~ /^DISTINCT\s*COUNT$/i ) {
$name = "COUNT(DISTINCT $name)";
}
# If we want to substitute
- elsif ($func =~ /\?/) {
- $name = join($name,split(/\?/,$func));
+ elsif ($func =~ s/\?/$name/g) {
+ $name = $func;
}
# If we want to call a simple function on the column
elsif ($func !~ /\(/) {
@@ -1544,12 +1588,36 @@ sub Column {
} else {
$name = $func;
}
-
+ }
+ elsif ( $args{FUNCTION} ) {
+ $name = $args{FUNCTION};
+ }
+ elsif ( $args{FIELD} ) {
+ $name = $args{'ALIAS'} .'.'. $args{'FIELD'};
+ }
+ else {
+ $name = 'NULL';
}
- my $column = "col" . @{ $self->{columns} ||= [] };
- $column = $args{FIELD} if $table eq $self->Table and !$args{ALIAS};
- push @{ $self->{columns} }, "$name AS \L$column";
+ my $column;
+ if (
+ $args{FIELD} && $args{ALIAS} eq 'main'
+ && (!$args{'TABLE'} || $args{'TABLE'} eq $self->Table )
+ ) {
+ $column = $args{FIELD};
+
+ # make sure we don't fetch columns with duplicate aliases
+ if ( $self->{columns} ) {
+ my $suffix = " AS \L$column";
+ if ( grep index($_, $suffix, -length $suffix) >= 0, @{ $self->{columns} } ) {
+ $column .= scalar @{ $self->{columns} };
+ }
+ }
+ }
+ else {
+ $column = "col" . @{ $self->{columns} ||= [] };
+ }
+ push @{ $self->{columns} ||= [] }, "$name AS \L$column";
return $column;
}
diff --git a/SearchBuilder/Handle.pm b/lib/DBIx/SearchBuilder/Handle.pm
similarity index 81%
rename from SearchBuilder/Handle.pm
rename to lib/DBIx/SearchBuilder/Handle.pm
index 96acb07..4d09e20 100755
--- a/SearchBuilder/Handle.pm
+++ b/lib/DBIx/SearchBuilder/Handle.pm
@@ -72,51 +72,46 @@ the handle will be automatically "upgraded" into that subclass.
=cut
sub Connect {
- my $self = shift;
-
- my %args = ( Driver => undef,
- Database => undef,
- Host => undef,
- SID => undef,
- Port => undef,
- User => undef,
- Password => undef,
- RequireSSL => undef,
- DisconnectHandleOnDestroy => undef,
- @_);
-
- if( $args{'Driver'} && !$self->isa( 'DBIx::SearchBuilder::Handle::'. $args{'Driver'} ) ) {
- if ( $self->_UpgradeHandle($args{Driver}) ) {
- return ($self->Connect( %args ));
- }
- }
-
-
- my $dsn = $self->DSN || '';
+ my $self = shift;
+ my %args = (
+ Driver => undef,
+ Database => undef,
+ Host => undef,
+ SID => undef,
+ Port => undef,
+ User => undef,
+ Password => undef,
+ RequireSSL => undef,
+ DisconnectHandleOnDestroy => undef,
+ @_
+ );
- # Setting this actually breaks old RT versions in subtle ways. So we need to explicitly call it
+ if ( $args{'Driver'} && !$self->isa( __PACKAGE__ .'::'. $args{'Driver'} ) ) {
+ return $self->Connect( %args ) if $self->_UpgradeHandle( $args{'Driver'} );
+ }
+ # Setting this actually breaks old RT versions in subtle ways.
+ # So we need to explicitly call it
$self->{'DisconnectHandleOnDestroy'} = $args{'DisconnectHandleOnDestroy'};
-
- $self->BuildDSN(%args);
+ my $old_dsn = $self->DSN || '';
+ my $new_dsn = $self->BuildDSN( %args );
# Only connect if we're not connected to this source already
- if ((! $self->dbh ) || (!$self->dbh->ping) || ($self->DSN ne $dsn) ) {
- my $handle = DBI->connect($self->DSN, $args{'User'}, $args{'Password'}) || croak "Connect Failed $DBI::errstr\n" ;
-
- #databases do case conversion on the name of columns returned.
- #actually, some databases just ignore case. this smashes it to something consistent
- $handle->{FetchHashKeyName} ='NAME_lc';
+ return undef if $self->dbh && $self->dbh->ping && $new_dsn eq $old_dsn;
- #Set the handle
- $self->dbh($handle);
-
- return (1);
- }
+ my $handle = DBI->connect(
+ $new_dsn, $args{'User'}, $args{'Password'}
+ ) or croak "Connect Failed $DBI::errstr\n";
- return(undef);
+ # databases do case conversion on the name of columns returned.
+ # actually, some databases just ignore case. this smashes it to something consistent
+ $handle->{FetchHashKeyName} ='NAME_lc';
+ # Set the handle
+ $self->dbh($handle);
+
+ return 1;
}
@@ -141,8 +136,6 @@ sub _UpgradeHandle {
}
-
-
=head2 BuildDSN PARAMHASH
Takes a bunch of parameters:
@@ -156,29 +149,29 @@ Builds a DSN suitable for a DBI connection
sub BuildDSN {
my $self = shift;
- my %args = ( Driver => undef,
- Database => undef,
- Host => undef,
- Port => undef,
- SID => undef,
- RequireSSL => undef,
- @_);
-
-
- my $dsn = "dbi:$args{'Driver'}:dbname=$args{'Database'}";
- $dsn .= ";sid=$args{'SID'}" if ( defined $args{'SID'} && $args{'SID'});
- $dsn .= ";host=$args{'Host'}" if (defined$args{'Host'} && $args{'Host'});
- $dsn .= ";port=$args{'Port'}" if (defined $args{'Port'} && $args{'Port'});
- $dsn .= ";requiressl=1" if (defined $args{'RequireSSL'} && $args{'RequireSSL'});
+ my %args = (
+ Driver => undef,
+ Database => undef,
+ Host => undef,
+ Port => undef,
+ SID => undef,
+ RequireSSL => undef,
+ @_
+ );
- $self->{'dsn'}= $dsn;
-}
+ my $dsn = "dbi:$args{'Driver'}:dbname=$args{'Database'}";
+ $dsn .= ";sid=$args{'SID'}" if $args{'SID'};
+ $dsn .= ";host=$args{'Host'}" if $args{'Host'};
+ $dsn .= ";port=$args{'Port'}" if $args{'Port'};
+ $dsn .= ";requiressl=1" if $args{'RequireSSL'};
+ return $self->{'dsn'} = $dsn;
+}
=head2 DSN
- Returns the DSN for this database connection.
+Returns the DSN for this database connection.
=cut
@@ -243,7 +236,7 @@ sub LogSQLStatements {
=head2 _LogSQLStatement STATEMENT DURATION
-add an SQL statement to our query log
+Add an SQL statement to our query log
=cut
@@ -384,6 +377,35 @@ sub InsertQueryString {
return ($QueryString, @bind);
}
+=head2 InsertFromSelect
+
+Takes table name, array reference with columns, select query
+and list of bind values. Inserts data select by the query
+into the table.
+
+To make sure call is portable every column in result of
+the query should have unique name or should be aliased.
+See L<DBIx::SearchBuilder::Handle::Oracle/InsertFromSelect> for
+details.
+
+=cut
+
+sub InsertFromSelect {
+ my ($self, $table, $columns, $query, @binds) = @_;
+
+ $columns = join ', ', @$columns
+ if $columns;
+
+ my $full_query = "INSERT INTO $table";
+ $full_query .= " ($columns)" if $columns;
+ $full_query .= ' '. $query;
+ my $sth = $self->SimpleQuery( $full_query, @binds );
+ return $sth unless $sth;
+
+ my $rows = $sth->rows;
+ return $rows == 0? '0E0' : $rows;
+}
+
=head2 UpdateRecordValue
Takes a hash with fields: Table, Column, Value PrimaryKeys, and
@@ -453,6 +475,62 @@ sub UpdateTableValue {
return $self->UpdateRecordValue(%args)
}
+=head1 SimpleUpdateFromSelect
+
+Takes table name, hash reference with (column, value) pairs,
+select query and list of bind values.
+
+Updates the table, but only records with IDs returned by the
+selected query, eg:
+
+ UPDATE $table SET %values WHERE id IN ( $query )
+
+It's simple as values are static and search only allowed
+by id.
+
+=cut
+
+sub SimpleUpdateFromSelect {
+ my ($self, $table, $values, $query, @query_binds) = @_;
+
+ my @columns; my @binds;
+ while ( my ($k, $v) = each %$values ) {
+ push @columns, $k;
+ push @binds, $v;
+ }
+
+ my $full_query = "UPDATE $table SET ";
+ $full_query .= join ', ', map "$_ = ?", @columns;
+ $full_query .= ' WHERE id IN ('. $query .')';
+ my $sth = $self->SimpleQuery( $full_query, @binds );
+ return $sth unless $sth;
+
+ my $rows = $sth->rows;
+ return $rows == 0? '0E0' : $rows;
+}
+
+=head1 DeleteFromSelect
+
+Takes table name, select query and list of bind values.
+
+Deletes from the table, but only records with IDs returned by the
+select query, eg:
+
+ DELETE FROM $table WHERE id IN ($query)
+
+=cut
+
+sub DeleteFromSelect {
+ my ($self, $table, $query, @binds) = @_;
+ my $sth = $self->SimpleQuery(
+ "DELETE FROM $table WHERE id IN ($query)",
+ @binds
+ );
+ return $sth unless $sth;
+
+ my $rows = $sth->rows;
+ return $rows == 0? '0E0' : $rows;
+}
=head2 SimpleQuery QUERY_STRING, [ BIND_VALUE, ... ]
@@ -1361,6 +1439,159 @@ sub Log {
}
+=head2 SimpleDateTimeFunctions
+
+See L</DateTimeFunction> for details on supported functions.
+This method is for implementers of custom DB connectors.
+
+Returns hash reference with (function name, sql template) pairs.
+
+=cut
+
+sub SimpleDateTimeFunctions {
+ my $self = shift;
+ return {
+ datetime => 'SUBSTR(?, 1, 19)',
+ time => 'SUBSTR(?, 12, 8)',
+
+ hourly => 'SUBSTR(?, 1, 13)',
+ hour => 'SUBSTR(?, 12, 2 )',
+
+ date => 'SUBSTR(?, 1, 10)',
+ daily => 'SUBSTR(?, 1, 10)',
+
+ day => 'SUBSTR(?, 9, 2 )',
+ dayofmonth => 'SUBSTR(?, 9, 2 )',
+
+ monthly => 'SUBSTR(?, 1, 7 )',
+ month => 'SUBSTR(?, 6, 2 )',
+
+ annually => 'SUBSTR(?, 1, 4 )',
+ year => 'SUBSTR(?, 1, 4 )',
+ };
+}
+
+=head2 DateTimeFunction
+
+Takes named arguments:
+
+=over 4
+
+=item * Field - SQL expression date/time function should be applied
+to. Note that this argument is used as is without any kind of quoting.
+
+=item * Type - name of the function, see supported values below.
+
+=item * Timezone - optional hash reference with From and To values,
+see L</ConvertTimezoneFunction> for details.
+
+=back
+
+Returns SQL statement. Returns NULL if function is not supported.
+
+=head3 Supported functions
+
+Type value in L</DateTimeFunction> is case insesitive. Spaces,
+underscores and dashes are ignored. So 'date time', 'DateTime'
+and 'date_time' are all synonyms. The following functions are
+supported:
+
+=over 4
+
+=item * date time - as is, no conversion, except applying timezone
+conversion if it's provided.
+
+=item * time - time only
+
+=item * hourly - datetime prefix up to the hours, e.g. '2010-03-25 16'
+
+=item * hour - hour, 0 - 23
+
+=item * date - date only
+
+=item * daily - synonym for date
+
+=item * day of week - 0 - 6, 0 - Sunday
+
+=item * day - day of month, 1 - 31
+
+=item * day of month - synonym for day
+
+=item * day of year - 1 - 366, support is database dependent
+
+=item * month - 1 - 12
+
+=item * monthly - year and month prefix, e.g. '2010-11'
+
+=item * year - e.g. '2023'
+
+=item * annually - synonym for year
+
+=item * week of year - 0-53, presence of zero week, 1st week meaning
+and whether week starts on Monday or Sunday heavily depends on database.
+
+=back
+
+=cut
+
+sub DateTimeFunction {
+ my $self = shift;
+ my %args = (
+ Field => undef,
+ Type => undef,
+ Timezone => undef,
+ @_
+ );
+
+ my $res = $args{'Field'} || '?';
+ if ( $args{'Timezone'} ) {
+ $res = $self->ConvertTimezoneFunction(
+ %{ $args{'Timezone'} },
+ Field => $res,
+ );
+ }
+
+ my $norm_type = lc $args{'Type'};
+ $norm_type =~ s/[ _-]//g;
+ if ( my $template = $self->SimpleDateTimeFunctions->{ $norm_type } ) {
+ $template =~ s/\?/$res/;
+ $res = $template;
+ }
+ else {
+ return 'NULL';
+ }
+ return $res;
+}
+
+=head2 ConvertTimezoneFunction
+
+Generates a function applied to Field argument that converts timezone.
+By default converts from UTC. Examples:
+
+ # UTC => Moscow
+ $handle->ConvertTimezoneFunction( Field => '?', To => 'Europe/Moscow');
+
+If there is problem with arguments or timezones are equal
+then Field returned without any function applied. Field argument
+is not escaped in any way, it's your job.
+
+Implementation is very database specific. To be portable convert
+from UTC or to UTC. Some databases have internal storage for
+information about timezones that should be kept up to date.
+Read documentation for your DB.
+
+=cut
+
+sub ConvertTimezoneFunction {
+ my $self = shift;
+ my %args = (
+ From => 'UTC',
+ To => undef,
+ Field => '',
+ @_
+ );
+ return $args{'Field'};
+}
=head2 DESTROY
diff --git a/SearchBuilder/Handle/Informix.pm b/lib/DBIx/SearchBuilder/Handle/Informix.pm
similarity index 100%
rename from SearchBuilder/Handle/Informix.pm
rename to lib/DBIx/SearchBuilder/Handle/Informix.pm
diff --git a/SearchBuilder/Handle/ODBC.pm b/lib/DBIx/SearchBuilder/Handle/ODBC.pm
similarity index 100%
rename from SearchBuilder/Handle/ODBC.pm
rename to lib/DBIx/SearchBuilder/Handle/ODBC.pm
diff --git a/SearchBuilder/Handle/Oracle.pm b/lib/DBIx/SearchBuilder/Handle/Oracle.pm
similarity index 62%
rename from SearchBuilder/Handle/Oracle.pm
rename to lib/DBIx/SearchBuilder/Handle/Oracle.pm
index de0a6bf..ad49eee 100755
--- a/SearchBuilder/Handle/Oracle.pm
+++ b/lib/DBIx/SearchBuilder/Handle/Oracle.pm
@@ -47,12 +47,61 @@ sub Connect {
$self->dbh->{LongTruncOk}=1;
$self->dbh->{LongReadLen}=8000;
-
- $self->SimpleQuery("ALTER SESSION set NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'");
+
+ foreach my $setting (qw(DATE TIMESTAMP TIMESTAMP_TZ)) {
+ $self->SimpleQuery(
+ "ALTER SESSION set NLS_${setting}_FORMAT = 'YYYY-MM-DD HH24:MI:SS'"
+ );
+ }
return ($rv);
}
+=head2 BuildDSN
+
+Customized version of L<DBIx::SearchBuilder::Handle/BuildDSN> method.
+
+Takes additional argument SID. Database argument used unless SID provided.
+Two forms of DSN are generated depending on whether Host defined or not:
+
+ dbi:Oracle:sid=<SID>;host=...[;port=...]
+ dbi:Oracle:<SID>
+
+Read details in documentation for L<DBD::Oracle> module.
+
+=cut
+
+sub BuildDSN {
+ my $self = shift;
+ my %args = (
+ Driver => undef,
+ Database => undef,
+ Host => undef,
+ Port => undef,
+ SID => undef,
+ @_
+ );
+ $args{'Driver'} ||= 'Oracle';
+
+# read DBD::Oracle for details, but basicly it supports
+# either 'dbi:Oracle:SID' or 'dbi:Oracle:sid=SID;host=...;[port=...;]'
+# and tests shows that 'dbi:Oracle:SID' != 'dbi:Oracle:sid=SID'
+
+ $args{'SID'} ||= $args{'Database'};
+ my $dsn = "dbi:$args{'Driver'}:";
+ if ( $args{'Host'} ) {
+ $dsn .= "sid=$args{'SID'}" if $args{'SID'};
+ $dsn .= ";host=$args{'Host'}";
+ $dsn .= ";port=$args{'Port'}" if $args{'Port'};
+ }
+ else {
+ $dsn .= $args{'SID'} if $args{'SID'};
+ $dsn .= ";port=$args{'Port'}" if $args{'Port'};
+ }
+
+ return $self->{'dsn'} = $dsn;
+}
+
=head2 Insert
@@ -117,44 +166,41 @@ sub Insert {
return( $self->{'id'}); #Add Succeded. return the id
}
+=head2 InsertFromSelect
+Customization of L<DBIx::SearchBuilder::Handle/InsertFromSelect>.
-=head2 BuildDSN PARAMHASH
+Unlike other DBs Oracle needs:
-Takes a bunch of parameters:
+=over 4
-Required: Driver, Database or Host/SID,
-Optional: Port and RequireSSL
+=item * id generated from sequences for every new record.
-Builds a DSN suitable for an Oracle DBI connection
+=item * query wrapping in parens.
-=cut
+=back
-sub BuildDSN {
- my $self = shift;
- my %args = ( Driver => undef,
- Database => undef,
- Host => undef,
- Port => undef,
- SID => undef,
- RequireSSL => undef,
- @_);
-
- my $dsn = "dbi:$args{'Driver'}:";
+B<NOTE> that on Oracle there is a limitation on the query. Every
+column in the result should have unique name or alias, for example the
+following query would generate "ORA-00918: column ambiguously defined"
+error:
- if (defined $args{'Host'} && $args{'Host'}
- && defined $args{'SID'} && $args{'SID'} ) {
- $dsn .= "host=$args{'Host'};sid=$args{'SID'}";
- } else {
- $dsn .= "$args{'Database'}" if (defined $args{'Database'} && $args{'Database'});
- }
- $dsn .= ";port=$args{'Port'}" if (defined $args{'Port'} && $args{'Port'});
- $dsn .= ";requiressl=1" if (defined $args{'RequireSSL'} && $args{'RequireSSL'});
+ SELECT g.id, u.id FROM ...
- $self->{'dsn'}= $dsn;
-}
+Solve with aliases:
+
+ SELECT g.id AS group_id, u.id AS user_id FROM ...
+=cut
+sub InsertFromSelect {
+ my ($self, $table, $columns, $query, @binds) = @_;
+ if ( $columns && !grep lc($_) eq 'id', @$columns ) {
+ unshift @$columns, 'id';
+ $query = "SELECT ${table}_seq.nextval, insert_from.* FROM ($query) insert_from";
+ }
+ return $self->SUPER::InsertFromSelect( $table, $columns, "($query)", @binds);
+}
=head2 KnowsBLOBs
@@ -317,6 +363,78 @@ sub Fields {
return @{ $cache->{ lc $table } || [] };
}
+=head2 SimpleDateTimeFunctions
+
+Returns hash reference with specific date time functions of this
+database for L<DBIx::SearchBuilder::Handle/DateTimeFunction>.
+
+=cut
+
+# http://download.oracle.com/docs/cd/B14117_01/server.101/b10749/ch4datetime.htm
+sub SimpleDateTimeFunctions {
+ my $self = shift;
+ return $self->{'_simple_date_time_functions'}
+ if $self->{'_simple_date_time_functions'};
+
+ my %res = %{ $self->SUPER::SimpleDateTimeFunctions(@_) };
+
+ return $self->{'_simple_date_time_functions'} ||= {
+ %res,
+ datetime => "?",
+ time => "TO_CHAR(?, 'HH24:MI:SS')",
+
+ hourly => "TO_CHAR(?, 'YYYY-MM-DD HH24')",
+ hour => "TO_CHAR(?, 'HH24')",
+
+ date => "TO_CHAR(?, 'YYYY-MM-DD')",
+ daily => "TO_CHAR(?, 'YYYY-MM-DD')",
+
+ day => "TO_CHAR(?, 'DD')",
+ dayofmonth => "TO_CHAR(?, 'DD')",
+
+ monthly => "TO_CHAR(?, 'YYYY-MM')",
+ month => "TO_CHAR(?, 'MM')",
+
+ annually => "TO_CHAR(?, 'YYYY')",
+ year => "TO_CHAR(?, 'YYYY')",
+
+ dayofweek => "TO_CHAR(?, 'D') - 1", # 1-7, 1 - Sunday
+ dayofyear => "TO_CHAR(?, 'DDD')", # 1-366
+ # no idea about props
+ weekofyear => "TO_CHAR(?, 'WW')",
+ };
+}
+
+=head2 ConvertTimezoneFunction
+
+Custom implementation of L<DBIx::SearchBuilder::Handle/ConvertTimezoneFunction>.
+
+Use the following query to get list of timezones:
+
+ SELECT tzname FROM v$timezone_names;
+
+Read Oracle's docs about timezone files:
+
+ http://download.oracle.com/docs/cd/B14117_01/server.101/b10749/ch4datetime.htm#i1006667
+
+=cut
+
+sub ConvertTimezoneFunction {
+ my $self = shift;
+ my %args = (
+ From => 'UTC',
+ To => undef,
+ Field => '',
+ @_
+ );
+ return $args{'Field'} unless $args{From} && $args{'To'};
+ return $args{'Field'} if lc $args{From} eq lc $args{'To'};
+
+ my $dbh = $self->dbh;
+ $_ = $dbh->quote( $_ ) foreach @args{'From', 'To'};
+ return "FROM_TZ( CAST ($args{'Field'} AS TIMESTAMP), $args{'From'}) AT TIME ZONE $args{'To'}";
+}
+
1;
__END__
diff --git a/SearchBuilder/Handle/Pg.pm b/lib/DBIx/SearchBuilder/Handle/Pg.pm
similarity index 73%
rename from SearchBuilder/Handle/Pg.pm
rename to lib/DBIx/SearchBuilder/Handle/Pg.pm
index c038e0d..df32079 100755
--- a/SearchBuilder/Handle/Pg.pm
+++ b/lib/DBIx/SearchBuilder/Handle/Pg.pm
@@ -251,6 +251,80 @@ sub DistinctQuery {
$$statementref = "SELECT main.* FROM $$statementref $group $order";
}
+=head2 SimpleDateTimeFunctions
+
+Returns hash reference with specific date time functions of this
+database for L<DBIx::SearchBuilder::Handle/DateTimeFunction>.
+
+=cut
+
+sub SimpleDateTimeFunctions {
+ my $self = shift;
+ return $self->{'_simple_date_time_functions'}
+ if $self->{'_simple_date_time_functions'};
+
+ my %res = %{ $self->SUPER::SimpleDateTimeFunctions(@_) };
+ s/SUBSTR\s*\(\s*\?/SUBSTR( CAST(? AS text)/ig for values %res;
+
+ # everything else we should implement through date_trunc that
+ # does SUBSTR(?, 1, X) on a date, but leaves trailing values
+ # when we don't need them
+
+ return $self->{'_simple_date_time_functions'} ||= {
+ %res,
+ datetime => '?',
+ time => 'CAST(? AS time)',
+
+ hour => 'EXTRACT(HOUR FROM ?)',
+
+ date => 'CAST(? AS date)',
+ daily => 'CAST(? AS date)',
+
+ day => 'EXTRACT(DAY FROM ?)',
+
+ month => 'EXTRACT(MONTH FROM ?)',
+
+ annually => 'EXTRACT(YEAR FROM ?)',
+ year => 'EXTRACT(YEAR FROM ?)',
+
+ dayofweek => "EXTRACT(DOW FROM ?)", # 0-6, 0 - Sunday
+ dayofyear => "EXTRACT(DOY FROM ?)", # 1-366
+ # 1-53, 1st week January 4, week starts on Monay
+ weekofyear => "EXTRACT(WEEK FROM ?)",
+ };
+}
+
+=head2 ConvertTimezoneFunction
+
+Custom implementation of L<DBIx::SearchBuilder::Handle/ConvertTimezoneFunction>.
+
+In Pg time and timestamp data types may be "with time zone" or "without time zone".
+So if Field argument is timestamp "with time zone" then From argument is not
+required and is useless. Otherwise From argument identifies time zone of the Field
+argument that is "without time zone".
+
+For consistency with other DBs use timestamp columns without time zones and provide
+From argument.
+
+=cut
+
+sub ConvertTimezoneFunction {
+ my $self = shift;
+ my %args = (
+ From => 'UTC',
+ To => undef,
+ Field => '',
+ @_
+ );
+ return $args{'Field'} unless $args{From} && $args{'To'};
+ return $args{'Field'} if lc $args{From} eq lc $args{'To'};
+
+ my $dbh = $self->dbh;
+ my $res = $args{'Field'};
+ $res = "TIMEZONE($_, $res)" foreach map $dbh->quote( $_ ), grep $_, @args{'From', 'To'};
+ return $res;
+}
+
1;
__END__
diff --git a/SearchBuilder/Handle/SQLite.pm b/lib/DBIx/SearchBuilder/Handle/SQLite.pm
similarity index 69%
rename from SearchBuilder/Handle/SQLite.pm
rename to lib/DBIx/SearchBuilder/Handle/SQLite.pm
index d78ba63..b7985cb 100644
--- a/SearchBuilder/Handle/SQLite.pm
+++ b/lib/DBIx/SearchBuilder/Handle/SQLite.pm
@@ -149,6 +149,65 @@ sub Fields {
return @{ $cache->{ lc $table } || [] };
}
+=head2 SimpleDateTimeFunctions
+
+Returns hash reference with specific date time functions of this
+database for L<DBIx::SearchBuilder::Handle/DateTimeFunction>.
+
+=cut
+
+sub SimpleDateTimeFunctions {
+ my $self = shift;
+ return $self->{'_simple_date_time_functions'} ||= {
+ %{ $self->SUPER::SimpleDateTimeFunctions(@_) },
+ datetime => 'datetime(?)',
+ time => 'time(?)',
+
+ hourly => "strftime('%Y-%m-%d %H', ?)",
+ hour => "strftime('%H', ?)",
+
+ date => 'date(?)',
+ daily => 'date(?)',
+
+ day => "strftime('%d', ?)",
+ dayofmonth => "strftime('%d', ?)",
+
+ monthly => "strftime('%Y-%m', ?)",
+ month => "strftime('%m', ?)",
+
+ annually => "strftime('%Y', ?)",
+ year => "strftime('%Y', ?)",
+
+ dayofweek => "strftime('%w', ?)",
+ dayofyear => "strftime('%j', ?)",
+ weekofyear => "strftime('%W', ?)",
+ };
+}
+
+sub ConvertTimezoneFunction {
+ my $self = shift;
+ my %args = (
+ From => 'UTC',
+ To => undef,
+ Field => '',
+ @_
+ );
+ return $args{'Field'} unless $args{From} && $args{'To'};
+ return $args{'Field'} if lc $args{From} eq lc $args{'To'};
+
+ my $res;
+ if ( lc($args{'To'}||'') eq 'utc' ) {
+ $res = "datetime($args{'Field'}, 'utc')";
+ }
+ elsif ( lc($args{'From'}||'') eq 'utc' ) {
+ $res = "datetime($args{'Field'}, 'localtime')";
+ }
+ else {
+ warn "SQLite only supports TZ convesion from UTC or to UTC";
+ $res = $args{'Field'};
+ }
+ return $res;
+}
1;
diff --git a/SearchBuilder/Handle/Sybase.pm b/lib/DBIx/SearchBuilder/Handle/Sybase.pm
similarity index 100%
rename from SearchBuilder/Handle/Sybase.pm
rename to lib/DBIx/SearchBuilder/Handle/Sybase.pm
diff --git a/lib/DBIx/SearchBuilder/Handle/mysql.pm b/lib/DBIx/SearchBuilder/Handle/mysql.pm
new file mode 100755
index 0000000..5c56ca9
--- /dev/null
+++ b/lib/DBIx/SearchBuilder/Handle/mysql.pm
@@ -0,0 +1,298 @@
+# $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/mysql.pm,v 1.8 2001/10/12 05:27:05 jesse Exp $
+
+package DBIx::SearchBuilder::Handle::mysql;
+
+use strict;
+use warnings;
+
+use base qw(DBIx::SearchBuilder::Handle);
+
+=head1 NAME
+
+ DBIx::SearchBuilder::Handle::mysql - A mysql specific Handle object
+
+=head1 SYNOPSIS
+
+
+=head1 DESCRIPTION
+
+This module provides a subclass of DBIx::SearchBuilder::Handle that
+compensates for some of the idiosyncrasies of MySQL.
+
+=head1 METHODS
+
+=head2 Insert
+
+Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted.
+
+If the insert succeeds, returns the id of the insert, otherwise, returns
+a Class::ReturnValue object with the error reported.
+
+=cut
+
+sub Insert {
+ my $self = shift;
+
+ my $sth = $self->SUPER::Insert(@_);
+ if (!$sth) {
+ return ($sth);
+ }
+
+ $self->{'id'}=$self->dbh->{'mysql_insertid'};
+
+ # Yay. we get to work around mysql_insertid being null some of the time :/
+ unless ($self->{'id'}) {
+ $self->{'id'} = $self->FetchResult('SELECT LAST_INSERT_ID()');
+ }
+ warn "$self no row id returned on row creation" unless ($self->{'id'});
+
+ return( $self->{'id'}); #Add Succeded. return the id
+ }
+
+
+=head2 SimpleUpdateFromSelect
+
+Customization of L<DBIx::SearchBuilder::Handle/SimpleUpdateFromSelect>.
+Mysql doesn't support update with subqueries when those fetch data from
+the table that is updated.
+
+=cut
+
+sub SimpleUpdateFromSelect {
+ my ($self, $table, $values, $query, @query_binds) = @_;
+
+ return $self->SUPER::SimpleUpdateFromSelect(
+ $table, $values, $query, @query_binds
+ ) unless $query =~ /\b\Q$table\E\b/i;
+
+ my $sth = $self->SimpleQuery( $query, @query_binds );
+ return $sth unless $sth;
+
+ my (@binds, @columns);
+ while ( my ($k, $v) = each %$values ) {
+ push @columns, $k;
+ push @binds, $v;
+ }
+
+ my $update_query = "UPDATE $table SET "
+ . join( ', ', map "$_ = ?", @columns )
+ .' WHERE ID IN ';
+
+ return $self->SimpleMassChangeFromSelect(
+ $update_query, \@binds,
+ $query, @query_binds
+ );
+}
+
+
+sub DeleteFromSelect {
+ my ($self, $table, $query, @query_binds) = @_;
+
+ return $self->SUPER::DeleteFromSelect(
+ $table, $query, @query_binds
+ ) unless $query =~ /\b\Q$table\E\b/i;
+
+ return $self->SimpleMassChangeFromSelect(
+ "DELETE FROM $table WHERE id IN ", [],
+ $query, @query_binds
+ );
+}
+
+sub SimpleMassChangeFromSelect {
+ my ($self, $update_query, $update_binds, $search, @search_binds) = @_;
+
+ my $sth = $self->SimpleQuery( $search, @search_binds );
+ return $sth unless $sth;
+
+
+ # tried TEMPORARY tables, much slower than fetching and delete
+ # also size of ENGINE=MEMORY is limitted by option, on disk
+ # tables more slower than in memory
+ my $res = 0;
+
+ my @ids;
+ while ( my $id = ($sth->fetchrow_array)[0] ) {
+ push @ids, $id;
+ next if @ids < 1000;
+
+ my $q = $update_query .'('. join( ',', ('?')x at ids ) .')';
+ my $sth = $self->SimpleQuery( $q, @$update_binds, splice @ids );
+ return $sth unless $sth;
+
+ $res += $sth->rows;
+ }
+ if ( @ids ) {
+ my $q = $update_query .'('. join( ',', ('?')x at ids ) .')';
+ my $sth = $self->SimpleQuery( $q, @$update_binds, splice @ids );
+ return $sth unless $sth;
+
+ $res += $sth->rows;
+ }
+ return $res == 0? '0E0': $res;
+}
+
+=head2 DatabaseVersion
+
+Returns the mysql version, trimming off any -foo identifier
+
+=cut
+
+sub DatabaseVersion {
+ my $self = shift;
+ my $v = $self->SUPER::DatabaseVersion();
+
+ $v =~ s/\-.*$//;
+ return ($v);
+}
+
+=head2 CaseSensitive
+
+Returns undef, since mysql's searches are not case sensitive by default
+
+=cut
+
+sub CaseSensitive {
+ my $self = shift;
+ return(undef);
+}
+
+sub DistinctQuery {
+ my $self = shift;
+ my $statementref = shift;
+ my $sb = shift;
+
+ return $self->SUPER::DistinctQuery( $statementref, $sb, @_ )
+ if $sb->_OrderClause !~ /(?<!main)\./;
+
+ if ( substr($self->DatabaseVersion, 0, 1) == 4 ) {
+ local $sb->{'group_by'} = [{FIELD => 'id'}];
+
+ my ($idx, @tmp, @specials) = (0, ());
+ foreach ( @{$sb->{'order_by'}} ) {
+ if ( !exists $_->{'ALIAS'} || ($_->{'ALIAS'}||'') eq "main" ) {
+ push @tmp, $_; next;
+ }
+
+ push @specials,
+ ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN')
+ ."(". $_->{'ALIAS'} .".". $_->{'FIELD'} .")"
+ ." __special_sort_$idx";
+ push @tmp, { ALIAS => '', FIELD => "__special_sort_$idx", ORDER => $_->{'ORDER'} };
+ $idx++;
+ }
+
+ local $sb->{'order_by'} = \@tmp;
+ $$statementref = "SELECT ". join( ", ", 'main.*', @specials ) ." FROM $$statementref";
+ $$statementref .= $sb->_GroupClause;
+ $$statementref .= $sb->_OrderClause;
+ } else {
+ local $sb->{'group_by'} = [{FIELD => 'id'}];
+ local $sb->{'order_by'} = [
+ map {
+ ($_->{'ALIAS'}||'') ne "main"
+ ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" }
+ : $_
+ }
+ @{$sb->{'order_by'}}
+ ];
+ $$statementref = "SELECT main.* FROM $$statementref";
+ $$statementref .= $sb->_GroupClause;
+ $$statementref .= $sb->_OrderClause;
+ }
+}
+
+sub Fields {
+ my $self = shift;
+ my $table = shift;
+
+ my $cache = \%DBIx::SearchBuilder::Handle::FIELDS_IN_TABLE;
+ unless ( $cache->{ lc $table } ) {
+ my $sth = $self->dbh->column_info( undef, undef, $table, '%' )
+ or return ();
+ my $info = $sth->fetchall_arrayref({});
+ foreach my $e ( sort {$a->{'ORDINAL_POSITION'} <=> $b->{'ORDINAL_POSITION'}} @$info ) {
+ push @{ $cache->{ lc $e->{'TABLE_NAME'} } ||= [] }, lc $e->{'COLUMN_NAME'};
+ }
+ }
+ return @{ $cache->{ lc $table } || [] };
+}
+
+=head2 SimpleDateTimeFunctions
+
+Returns hash reference with specific date time functions of this
+database for L<DBIx::SearchBuilder::Handle/DateTimeFunction>.
+
+=cut
+
+sub SimpleDateTimeFunctions {
+ my $self = shift;
+ return $self->{'_simple_date_time_functions'} ||= {
+ %{ $self->SUPER::SimpleDateTimeFunctions(@_) },
+ datetime => '?',
+ time => 'TIME(?)',
+
+ hourly => "DATE_FORMAT(?, '%Y-%m-%d %H')",
+ hour => 'HOUR(?)',
+
+ date => 'DATE(?)',
+ daily => 'DATE(?)',
+
+ day => 'DAYOFMONTH(?)',
+ dayofmonth => 'DAYOFMONTH(?)',
+
+ monthly => "DATE_FORMAT(?, '%Y-%m')",
+ month => 'MONTH(?)',
+
+ annually => 'YEAR(?)',
+ year => 'YEAR(?)',
+
+ dayofweek => "DAYOFWEEK(?) - 1", # 1-7, 1 - Sunday
+ dayofyear => "DAYOFYEAR(?)", # 1-366
+ weekofyear => "WEEK(?)", # skip mode argument, so it can be controlled in mysql config
+ };
+}
+
+
+=head2 ConvertTimezoneFunction
+
+Custom implementation of L<DBIx::SearchBuilder::Handle/ConvertTimezoneFunction>.
+
+Use the following query to get list of timezones:
+
+ SELECT Name FROM mysql.time_zone_name;
+
+Read docs about keeping timezone data up to date:
+
+ http://dev.mysql.com/doc/refman/5.5/en/time-zone-upgrades.html
+
+=cut
+
+sub ConvertTimezoneFunction {
+ my $self = shift;
+ my %args = (
+ From => 'UTC',
+ To => undef,
+ Field => '',
+ @_
+ );
+ return $args{'Field'} unless $args{From} && $args{'To'};
+ return $args{'Field'} if lc $args{From} eq lc $args{'To'};
+ my $dbh = $self->dbh;
+ $_ = $dbh->quote( $_ ) foreach @args{'From', 'To'};
+ return "CONVERT_TZ( $args{'Field'}, $args{'From'}, $args{'To'} )";
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Jesse Vincent, jesse at fsck.com
+
+=head1 SEE ALSO
+
+DBIx::SearchBuilder, DBIx::SearchBuilder::Handle
+
+=cut
+
diff --git a/SearchBuilder/Handle/mysqlPP.pm b/lib/DBIx/SearchBuilder/Handle/mysqlPP.pm
similarity index 100%
rename from SearchBuilder/Handle/mysqlPP.pm
rename to lib/DBIx/SearchBuilder/Handle/mysqlPP.pm
diff --git a/SearchBuilder/Record.pm b/lib/DBIx/SearchBuilder/Record.pm
similarity index 99%
rename from SearchBuilder/Record.pm
rename to lib/DBIx/SearchBuilder/Record.pm
index bd1af42..5bd4cf3 100755
--- a/SearchBuilder/Record.pm
+++ b/lib/DBIx/SearchBuilder/Record.pm
@@ -1281,12 +1281,12 @@ sub Create {
# Support for databases which don't deal with LOBs automatically
my $ca = $self->_ClassAccessible();
foreach $key ( keys %attribs ) {
- if ( $ca->{$key}->{'type'} =~ /^(text|longtext|clob|blob|lob)$/i ) {
- my $bhash =
- $self->_Handle->BLOBParams( $key, $ca->{$key}->{'type'} );
- $bhash->{'value'} = $attribs{$key};
- $attribs{$key} = $bhash;
- }
+ my $type = $ca->{$key}->{'type'};
+ next unless $type && $type =~ /^(text|longtext|clob|blob|lob)$/i;
+
+ my $bhash = $self->_Handle->BLOBParams( $key, $type );
+ $bhash->{'value'} = $attribs{$key};
+ $attribs{$key} = $bhash;
}
}
return ( $self->_Handle->Insert( $self->Table, %attribs ) );
diff --git a/SearchBuilder/Record/Cachable.pm b/lib/DBIx/SearchBuilder/Record/Cachable.pm
similarity index 100%
rename from SearchBuilder/Record/Cachable.pm
rename to lib/DBIx/SearchBuilder/Record/Cachable.pm
diff --git a/SearchBuilder/SchemaGenerator.pm b/lib/DBIx/SearchBuilder/SchemaGenerator.pm
similarity index 100%
rename from SearchBuilder/SchemaGenerator.pm
rename to lib/DBIx/SearchBuilder/SchemaGenerator.pm
diff --git a/SearchBuilder/Union.pm b/lib/DBIx/SearchBuilder/Union.pm
similarity index 100%
rename from SearchBuilder/Union.pm
rename to lib/DBIx/SearchBuilder/Union.pm
diff --git a/SearchBuilder/Unique.pm b/lib/DBIx/SearchBuilder/Unique.pm
similarity index 100%
rename from SearchBuilder/Unique.pm
rename to lib/DBIx/SearchBuilder/Unique.pm
diff --git a/t/00.load.t b/t/00.load.t
index 7e700d5..cfc6dcb 100644
--- a/t/00.load.t
+++ b/t/00.load.t
@@ -20,11 +20,3 @@ BEGIN { use_ok("DBIx::SearchBuilder::Handle::SQLite"); }
BEGIN { use_ok("DBIx::SearchBuilder::Record"); }
BEGIN { use_ok("DBIx::SearchBuilder::Record::Cachable"); }
-# Commented out until ruslan sends code.
-#BEGIN {
-# SKIP: {
-# skip "Cache::Memcached is not installed", 1
-# unless eval { require Cache::Memcached };
-# use_ok("DBIx::SearchBuilder::Record::Memcached");
-# }
-#}
diff --git a/t/01searches.t b/t/01searches.t
index 285035d..9fdfc45 100644
--- a/t/01searches.t
+++ b/t/01searches.t
@@ -7,7 +7,7 @@ use Test::More;
BEGIN { require "t/utils.pl" }
our (@AvailableDrivers);
-use constant TESTS_PER_DRIVER => 105;
+use constant TESTS_PER_DRIVER => 117;
my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
plan tests => $total;
@@ -287,6 +287,44 @@ SKIP: {
is( $u->Login, 'glasser', "glasser is third in the list");
}
+# Let's play with Column
+ $users_obj = TestApp::Users->new( $handle );
+ $users_obj->UnLimit;
+ {
+ is( $users_obj->Column(FIELD => 'id'), 'id' );
+ isnt( my $id_alias = $users_obj->Column(FIELD => 'id'), 'id' );
+ my $u = $users_obj->Next;
+ is ( $u->_Value($id_alias), $u->id, "fetched id twice" );
+ }
+
+ $users_obj = TestApp::Users->new( $handle );
+ $users_obj->UnLimit;
+ {
+ is( $users_obj->Column(FIELD => 'id'), 'id' );
+ isnt( my $id_alias = $users_obj->Column(FIELD => 'id', FUNCTION => '? + 1'), 'id' );
+ my $u = $users_obj->Next;
+ is ( $u->_Value($id_alias), $u->id + 1, "fetched id and function based on id" )
+ or diag "wrong SQL: ". $users_obj->BuildSelectQuery;
+ }
+
+ $users_obj = TestApp::Users->new( $handle );
+ $users_obj->UnLimit;
+ {
+ is( $users_obj->Column(FIELD => 'id'), 'id' );
+ isnt( my $id_alias = $users_obj->Column(FUNCTION => 'id + 1'), 'id' );
+ my $u = $users_obj->Next;
+ is ( $u->_Value($id_alias), $u->id + 1, "fetched id and function based on id" );
+ }
+
+ $users_obj = TestApp::Users->new( $handle );
+ $users_obj->UnLimit;
+ {
+ is( $users_obj->Column(FIELD => 'id'), 'id' );
+ isnt( my $id_alias = $users_obj->Column(FUNCTION => '?', FIELD => 'id'), 'id' );
+ my $u = $users_obj->Next;
+ is ( $u->_Value($id_alias), $u->id, "fetched with '?' function" );
+ }
+
cleanup_schema( 'TestApp', $handle );
}} # SKIP, foreach blocks
diff --git a/t/02distinct_values.t b/t/02distinct_values.t
index 4458903..f20328d 100644
--- a/t/02distinct_values.t
+++ b/t/02distinct_values.t
@@ -20,6 +20,7 @@ SKIP: {
unless( should_test( $d ) ) {
skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
}
+ diag "testing $d" if $ENV{TEST_VERBOSE};
my $handle = get_handle( $d );
connect_handle( $handle );
@@ -37,17 +38,25 @@ SKIP: {
# unlimit new object and check
$users_obj->UnLimit;
- is_deeply(
- [$users_obj->DistinctFieldValues('GroupName', Order => 'ASC')],
- [undef, qw(boss dev sales)],
- 'Correct list'
- );
- is_deeply(
- [$users_obj->DistinctFieldValues('GroupName', Order => 'DESC')],
- [reverse undef, qw(boss dev sales)],
- 'Correct list'
- );
- $users_obj->CleanSlate;
+ {
+ my @list = qw(boss dev sales);
+ if ( $d eq 'Pg' || $d eq 'Oracle' ) {
+ push @list, undef;
+ } else {
+ unshift @list, undef;
+ }
+ is_deeply(
+ [$users_obj->DistinctFieldValues('GroupName', Order => 'ASC')],
+ [@list],
+ 'Correct list'
+ );
+ is_deeply(
+ [$users_obj->DistinctFieldValues('GroupName', Order => 'DESC')],
+ [reverse @list],
+ 'Correct list'
+ );
+ $users_obj->CleanSlate;
+ }
$users_obj->Limit( FIELD => 'Login', OPERATOR => 'LIKE', VALUE => 'k' );
is_deeply(
diff --git a/t/02records_datetime.t b/t/02records_datetime.t
new file mode 100644
index 0000000..ed5df74
--- /dev/null
+++ b/t/02records_datetime.t
@@ -0,0 +1,365 @@
+#!/usr/bin/perl -w
+
+BEGIN { $ENV{'TZ'} = 'Europe/Moscow' };
+
+use strict;
+use warnings;
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@AvailableDrivers);
+
+use constant TESTS_PER_DRIVER => 38;
+
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+my $handle;
+
+foreach my $d ( @AvailableDrivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ diag "testing $d" if $ENV{'TEST_VERBOSE'};
+
+ my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back");
+
+ my $count_all = init_data( 'TestApp::User', $handle );
+ ok( $count_all, "init users data" );
+
+ is( $handle->DateTimeFunction, 'NULL', 'no type' );
+ is( $handle->DateTimeFunction( Type => 'bad function' ), 'NULL', 'bad type' );
+
+ is( $handle->ConvertTimezoneFunction( Field => '?' ), '?', 'no To argument' );
+ is( $handle->ConvertTimezoneFunction( To => 'utc', Field => '?' ), '?', 'From and To equal' );
+
+ foreach my $type ('date time', 'DateTime', 'date_time', 'Date-Time') {
+ run_test(
+ { Type => $type },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '2011-05-20 19:53:23',
+ },
+ );
+ run_test(
+ { Type => $type, Timezone => { To => 'Europe/Moscow' } },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '2011-05-20 23:53:23',
+ '2011-05-20 22:53:23' => '2011-05-21 02:53:23',
+ },
+ );
+ }
+
+ run_test(
+ { Type => 'time' },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '19:53:23',
+ },
+ );
+ run_test(
+ { Type => 'time', Timezone => { To => 'Europe/Moscow' } },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '23:53:23',
+ '2011-05-20 22:53:23' => '2:53:23',
+ },
+ );
+
+ run_test(
+ { Type => 'hourly' },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '2011-05-20 19',
+ '2011-05-20 22:53:23' => '2011-05-20 22',
+ },
+ );
+ run_test(
+ { Type => 'hourly', Timezone => { To => 'Europe/Moscow' } },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '2011-05-20 23',
+ '2011-05-20 22:53:23' => '2011-05-21 02',
+ },
+ );
+
+ run_test(
+ { Type => 'hour' },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '19',
+ },
+ );
+ run_test(
+ { Type => 'hour', Timezone => { To => 'Europe/Moscow' } },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '23',
+ '2011-05-20 22:53:23' => '2',
+ },
+ );
+
+ foreach my $type ( 'date', 'daily' ) {
+ run_test(
+ { Type => $type },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '2011-05-20',
+ },
+ );
+ run_test(
+ { Type => $type, Timezone => { To => 'Europe/Moscow' } },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '2011-05-20',
+ '2011-05-20 22:53:23' => '2011-05-21',
+ },
+ );
+ }
+
+ run_test(
+ { Type => 'day of week' },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '5',
+ '2011-05-21 19:53:23' => '6',
+ '2011-05-22 19:53:23' => '0',
+ '2011-05-20 22:53:23' => '5',
+ '2011-05-21 22:53:23' => '6',
+ '2011-05-22 22:53:23' => '0',
+ },
+ );
+ run_test(
+ { Type => 'day of week', Timezone => { To => 'Europe/Moscow' } },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '5',
+ '2011-05-21 19:53:23' => '6',
+ '2011-05-22 19:53:23' => '0',
+ '2011-05-20 22:53:23' => '6',
+ '2011-05-21 22:53:23' => '0',
+ '2011-05-22 22:53:23' => '1',
+ },
+ );
+
+
+ foreach my $type ( 'day', 'DayOfMonth' ) {
+ run_test(
+ { Type => $type },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '20',
+ '2011-05-20 22:53:23' => '20',
+ },
+ );
+ run_test(
+ { Type => $type, Timezone => { To => 'Europe/Moscow' } },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '20',
+ '2011-05-20 22:53:23' => '21',
+ },
+ );
+ }
+
+ run_test(
+ { Type => 'day of year' },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '140',
+ '2011-05-20 22:53:23' => '140',
+ },
+ );
+ run_test(
+ { Type => 'day of year', Timezone => { To => 'Europe/Moscow' } },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '140',
+ '2011-05-20 22:53:23' => '141',
+ },
+ );
+
+ run_test(
+ { Type => 'month' },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => 5,
+ },
+ );
+
+ run_test(
+ { Type => 'monthly' },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '2011-05',
+ },
+ );
+
+ foreach my $type ( 'year', 'annually' ) {
+ run_test(
+ { Type => $type },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '2011',
+ },
+ );
+ }
+
+ run_test(
+ { Type => 'week of year' },
+ {
+ '' => undef,
+ '2011-05-20 19:53:23' => '20',
+ },
+ );
+
+ cleanup_schema( 'TestApp', $handle );
+}} # SKIP, foreach blocks
+
+
+sub run_test {
+ my $props = shift;
+ my $expected = shift;
+
+ my $users = TestApp::Users->new( $handle );
+ $users->UnLimit;
+ $users->Column( FIELD => 'Expires' );
+ my $column = $users->Column(
+ ALIAS => 'main',
+ FIELD => 'Expires',
+ FUNCTION => $users->_Handle->DateTimeFunction( %$props ),
+ );
+
+ my %got;
+ while ( my $user = $users->Next ) {
+ $got{ $user->Expires || '' } = $user->__Value( $column );
+ }
+ foreach my $key ( keys %got ) {
+ delete $got{ $key } unless exists $expected->{ $key };
+
+ $got{ $key } =~ s/^0+(?!$)// if defined $got{ $key };
+ }
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ is_deeply( \%got, $expected, "correct ". $props->{'Type'} ." function" )
+ or diag "wrong SQL: ". $users->BuildSelectQuery;
+}
+
+1;
+
+package TestApp;
+
+sub schema_mysql {
+<<EOF;
+CREATE TEMPORARY TABLE Users (
+ id integer AUTO_INCREMENT,
+ Expires DATETIME NULL,
+ PRIMARY KEY (id)
+)
+EOF
+
+}
+
+sub schema_pg {
+<<EOF;
+CREATE TEMPORARY TABLE Users (
+ id serial PRIMARY KEY,
+ Expires TIMESTAMP NULL
+)
+EOF
+
+}
+
+sub schema_sqlite {
+
+<<EOF;
+CREATE TABLE Users (
+ id integer primary key,
+ Expires TEXT NULL
+)
+EOF
+
+}
+
+sub schema_oracle { [
+ "CREATE SEQUENCE Users_seq",
+ "CREATE TABLE Users (
+ id integer CONSTRAINT Users_Key PRIMARY KEY,
+ Expires DATE NULL
+ )",
+] }
+
+sub cleanup_schema_oracle { [
+ "DROP SEQUENCE Users_seq",
+ "DROP TABLE Users",
+] }
+
+
+1;
+
+package TestApp::User;
+
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
+
+sub _Init {
+ my $self = shift;
+ my $handle = shift;
+ $self->Table('Users');
+ $self->_Handle($handle);
+}
+
+sub _ClassAccessible {
+ {
+ id =>
+ {read => 1, type => 'int(11)' },
+ Expires =>
+ {read => 1, write => 1, type => 'datetime' },
+ }
+}
+
+sub init_data {
+ return (
+ [ 'Expires' ],
+ [ undef ],
+ [ '2011-05-20 19:53:23' ], # friday
+ [ '2011-05-21 19:53:23' ], # saturday
+ [ '2011-05-22 19:53:23' ], # sunday
+ [ '2011-05-20 22:53:23' ], # fri in UTC, sat in moscow
+ [ '2011-05-21 22:53:23' ], # sat in UTC, sun in moscow
+ [ '2011-05-22 22:53:23' ], # sun in UTC, mon in moscow
+ );
+}
+
+1;
+
+package TestApp::Users;
+
+# use TestApp::User;
+use base qw/DBIx::SearchBuilder/;
+
+sub _Init {
+ my $self = shift;
+ $self->SUPER::_Init( Handle => shift );
+ $self->Table('Users');
+}
+
+sub NewItem
+{
+ my $self = shift;
+ return TestApp::User->new( $self->_Handle );
+}
+
+1;
+
+
diff --git a/t/03compatibility.t b/t/03compatibility.t
new file mode 100644
index 0000000..14eb382
--- /dev/null
+++ b/t/03compatibility.t
@@ -0,0 +1,36 @@
+#!/usr/bin/perl -w
+
+
+use strict;
+use warnings;
+use Test::More;
+BEGIN { require "t/utils.pl" }
+our (@AvailableDrivers);
+
+use constant TESTS_PER_DRIVER => 2;
+
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+my %QUOTE_CHAR = ();
+
+foreach my $d ( @AvailableDrivers ) {
+SKIP: {
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ my $dbh = $handle->dbh;
+
+ my $q = $QUOTE_CHAR{$d} || "'";
+
+ # was problem in DBD::Pg, fixed in 1.40 back in 2005
+ is( $dbh->quote("\x{420}"), "$q\x{420}$q", "->quote don't clobber UTF-8 flag");
+
+}} # SKIP, foreach blocks
+
+1;
diff --git a/t/03cud_from_select.t b/t/03cud_from_select.t
new file mode 100644
index 0000000..3c40857
--- /dev/null
+++ b/t/03cud_from_select.t
@@ -0,0 +1,331 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+BEGIN { require "t/utils.pl" }
+our (@AvailableDrivers);
+
+use constant TESTS_PER_DRIVER => 14;
+
+my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+plan tests => $total;
+
+foreach my $d ( @AvailableDrivers ) {
+SKIP: {
+ unless( has_schema( 'TestApp', $d ) ) {
+ skip "No schema for '$d' driver", TESTS_PER_DRIVER;
+ }
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle->dbh, 'DBI::db');
+
+ my $ret = init_schema( 'TestApp', $handle );
+ isa_ok($ret, 'DBI::st', "Inserted the schema. got a statement handle back");
+
+ init_data( $_, $handle ) foreach qw(
+ TestApp::User
+ TestApp::Group
+ TestApp::UsersToGroup
+ );
+
+diag "insert into table from other tables only" if $ENV{'TEST_VERBOSE'};
+{
+ my $res = $handle->InsertFromSelect(
+ 'UsersToGroups' => ['UserId', 'GroupId'],
+ 'SELECT id, 1 FROM Users WHERE Login LIKE ?', '%o%'
+ );
+ is( $res, 2 );
+ my $users = TestApp::Users->new( $handle );
+ my $alias = $users->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' );
+ $users->Limit( ALIAS => $alias, FIELD => 'GroupId', VALUE => 1 );
+ is_deeply( [ sort map $_->Login, @{ $users->ItemsArrayRef } ], ['bob', 'john'] );
+}
+
+diag "insert into table from two tables" if $ENV{'TEST_VERBOSE'};
+{
+ my $res = $handle->InsertFromSelect(
+ 'UsersToGroups' => ['UserId', 'GroupId'],
+ 'SELECT u.id as col1, g.id as col2 FROM Users u, Groups g WHERE u.Login LIKE ? AND g.Name = ?',
+ '%a%', 'Support'
+ );
+ is( $res, 2 );
+ my $users = TestApp::Users->new( $handle );
+ my $u2g_alias = $users->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' );
+ my $g_alias = $users->Join(
+ ALIAS1 => $u2g_alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
+ );
+ $users->Limit( ALIAS => $g_alias, FIELD => 'Name', VALUE => 'Support' );
+ is_deeply( [ sort map $_->Login, @{ $users->ItemsArrayRef } ], ['aurelia', 'ivan'] );
+}
+
+{
+ my $res = $handle->DeleteFromSelect(
+ 'UsersToGroups' => 'SELECT id FROM UsersToGroups WHERE GroupId = 1'
+ );
+ is( $res, 2 );
+
+ my $users = TestApp::Users->new( $handle );
+ my $alias = $users->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' );
+ $users->Limit( ALIAS => $alias, FIELD => 'GroupId', VALUE => 1 );
+ is( $users->Count, 0 );
+}
+
+{
+ my $res = $handle->SimpleUpdateFromSelect(
+ 'UsersToGroups',
+ { UserId => 2, GroupId => 2 },
+ 'SELECT id FROM UsersToGroups WHERE UserId = 1 AND GroupId = 3'
+ );
+ is( $res, 1 );
+
+ my $u2gs = TestApp::UsersToGroups->new( $handle );
+ $u2gs->Limit( FIELD => 'UserId', VALUE => 1 );
+ $u2gs->Limit( FIELD => 'GroupId', VALUE => 3 );
+ is( $u2gs->Count, 0 );
+
+ $u2gs = TestApp::UsersToGroups->new( $handle );
+ $u2gs->Limit( FIELD => 'UserId', VALUE => 2 );
+ $u2gs->Limit( FIELD => 'GroupId', VALUE => 2 );
+ is( $u2gs->Count, 1 );
+}
+
+diag "insert into table from the same table" if $ENV{'TEST_VERBOSE'};
+{
+ my $res = $handle->InsertFromSelect(
+ 'UsersToGroups' => ['UserId', 'GroupId'],
+ 'SELECT GroupId, UserId FROM UsersToGroups',
+ );
+ is( $res, 2 );
+}
+
+diag "insert into table from two tables" if $ENV{'TEST_VERBOSE'};
+{ TODO: {
+ local $TODO;
+ $TODO = "No idea how to make it work on Oracle" if $d eq 'Oracle';
+ my $res = do {
+ local $handle->dbh->{'PrintError'} = 0;
+ local $SIG{__WARN__} = sub {};
+ $handle->InsertFromSelect(
+ 'UsersToGroups' => ['UserId', 'GroupId'],
+ 'SELECT u.id, g.id FROM Users u, Groups g WHERE u.Login LIKE ? AND g.Name = ?',
+ '%a%', 'Support'
+ );
+ };
+ is( $res, 2 );
+ my $users = TestApp::Users->new( $handle );
+ my $u2g_alias = $users->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' );
+ my $g_alias = $users->Join(
+ ALIAS1 => $u2g_alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
+ );
+ $users->Limit( ALIAS => $g_alias, FIELD => 'Name', VALUE => 'Support' );
+ is_deeply( [ sort map $_->Login, @{ $users->ItemsArrayRef } ], ['aurelia', 'ivan'] );
+} }
+
+ cleanup_schema( 'TestApp', $handle );
+
+}} # SKIP, foreach blocks
+
+1;
+
+
+package TestApp;
+sub schema_sqlite {
+[
+q{
+CREATE TABLE Users (
+ id integer primary key,
+ Login varchar(36)
+) },
+q{
+CREATE TABLE UsersToGroups (
+ id integer primary key,
+ UserId integer,
+ GroupId integer
+) },
+q{
+CREATE TABLE Groups (
+ id integer primary key,
+ Name varchar(36)
+) },
+]
+}
+
+# TEMPORARY tables can not be referenced more than once
+# in the same query, use real table for UsersToGroups
+sub schema_mysql {
+[
+q{
+CREATE TEMPORARY TABLE Users (
+ id integer primary key AUTO_INCREMENT,
+ Login varchar(36)
+) },
+q{
+CREATE TABLE UsersToGroups (
+ id integer primary key AUTO_INCREMENT,
+ UserId integer,
+ GroupId integer
+) },
+q{
+CREATE TEMPORARY TABLE Groups (
+ id integer primary key AUTO_INCREMENT,
+ Name varchar(36)
+) },
+]
+}
+
+sub cleanup_schema_mysql { [
+ "DROP TABLE UsersToGroups",
+] }
+
+sub schema_pg {
+[
+q{
+CREATE TEMPORARY TABLE Users (
+ id serial primary key,
+ Login varchar(36)
+) },
+q{
+CREATE TEMPORARY TABLE UsersToGroups (
+ id serial primary key,
+ UserId integer,
+ GroupId integer
+) },
+q{
+CREATE TEMPORARY TABLE Groups (
+ id serial primary key,
+ Name varchar(36)
+) },
+]
+}
+
+sub schema_oracle { [
+ "CREATE SEQUENCE Users_seq",
+ "CREATE TABLE Users (
+ id integer CONSTRAINT Users_Key PRIMARY KEY,
+ Login varchar(36)
+ )",
+ "CREATE SEQUENCE UsersToGroups_seq",
+ "CREATE TABLE UsersToGroups (
+ id integer CONSTRAINT UsersToGroups_Key PRIMARY KEY,
+ UserId integer,
+ GroupId integer
+ )",
+ "CREATE SEQUENCE Groups_seq",
+ "CREATE TABLE Groups (
+ id integer CONSTRAINT Groups_Key PRIMARY KEY,
+ Name varchar(36)
+ )",
+] }
+
+sub cleanup_schema_oracle { [
+ "DROP SEQUENCE Users_seq",
+ "DROP TABLE Users",
+ "DROP SEQUENCE Groups_seq",
+ "DROP TABLE Groups",
+ "DROP SEQUENCE UsersToGroups_seq",
+ "DROP TABLE UsersToGroups",
+] }
+
+package TestApp::Record;
+
+use base $ENV{SB_TEST_CACHABLE}?
+ qw/DBIx::SearchBuilder::Record::Cachable/:
+ qw/DBIx::SearchBuilder::Record/;
+
+sub _Init {
+ my $self = shift;
+ my $handle = shift;
+ $self->_Handle($handle);
+
+ my $table = ref $self || $self;
+ $table =~ s/.*:://;
+ $table .= 's';
+ $self->Table( $table );
+}
+
+package TestApp::Col;
+use base 'DBIx::SearchBuilder';
+
+sub _Init {
+ my $self = shift;
+ $self->SUPER::_Init( Handle => shift );
+
+ my $table = ref $self || $self;
+ $table =~ s/.*:://;
+ $self->Table( $table );
+}
+
+sub NewItem {
+ my $self = shift;
+ my $record_class = (ref($self) || $self);
+ $record_class =~ s/s$//;
+ return $record_class->new( $self->_Handle );
+}
+
+package TestApp::User;
+use base 'TestApp::Record';
+
+sub _ClassAccessible { return {
+ id => {read => 1, type => 'int(11)'},
+ Login => {read => 1, write => 1, type => 'varchar(36)'},
+} }
+
+sub init_data {
+ return (
+ [ 'Login' ],
+
+ [ 'ivan' ],
+ [ 'john' ],
+ [ 'bob' ],
+ [ 'aurelia' ],
+ );
+}
+
+package TestApp::Group;
+use base 'TestApp::Record';
+
+sub _ClassAccessible {
+ {
+ id => {read => 1, type => 'int(11)'},
+ Name => {read => 1, write => 1, type => 'varchar(36)'},
+ }
+}
+
+sub init_data {
+ return (
+ [ 'Name' ],
+
+ [ 'Developers' ],
+ [ 'Sales' ],
+ [ 'Support' ],
+ );
+}
+
+package TestApp::UsersToGroup;
+use base 'TestApp::Record';
+
+sub _ClassAccessible {
+ return {
+ id => {read => 1, type => 'int(11)'},
+ UserId => {read => 1, type => 'int(11)'},
+ GroupId => {read => 1, type => 'int(11)'},
+ }
+}
+
+sub init_data {
+ return ([ 'GroupId', 'UserId' ]);
+}
+
+package TestApp::Users;
+use base 'TestApp::Col';
+
+package TestApp::Groups;
+use base 'TestApp::Col';
+
+package TestApp::UsersToGroups;
+use base 'TestApp::Col';
--
Debian packaging of libdbix-searchbuilder-perl
More information about the Pkg-perl-cvs-commits
mailing list