DBIx-SearchBuilder-1.67/0000755000175000017500000000000012743225031014634 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/SIGNATURE0000644000175000017500000001316012743225031016121 0ustar vagrantvagrantThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.80. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 312bb7b5c24257f55575daeaa6f9cc22cd60f734 .gitignore SHA1 3a3111da29c451e7626f04541f24e2eb817ecb36 Changes SHA1 f9526289f15de085cbe55ce253b5964856fc3092 MANIFEST SHA1 ed6b392d54112ee960acf0c95777e4e1d81ba60b META.yml SHA1 6c9a672528cb66e5ab5ad053b2df792f1d0bbb03 Makefile.PL SHA1 d7a41642c368f2a587587e09f9e815d434feebff README SHA1 5a53d12d5cccd94845a6a7cc105cd9be34e20f1c ROADMAP SHA1 e7c7c7c91025072d25da78c93cefa2bc0aaf2b35 ex/Example/Model/Address.pm SHA1 f821661849153c21ad99393b6a3ea6720fdaf581 ex/Example/Model/Employee.pm SHA1 9689368197327e7b38af7f3d1f863e918ed4fa98 ex/create_tables.pl SHA1 9d3b2104a620fbaa1e5291400cb14385b205c8da inc/Module/AutoInstall.pm SHA1 bce3c51bb369419603298064b78e14077b93af66 inc/Module/Install.pm SHA1 93283b6d98078acdd04b242b3e994258821f4fe5 inc/Module/Install/AutoInstall.pm SHA1 fe220f215f645500ce8f14ff5e19d9a28692af56 inc/Module/Install/Base.pm SHA1 b56ed8e42c600e08007d152cf0b1438a7c3b7f6e inc/Module/Install/Can.pm SHA1 99c531a17a67ce5250df2ae151cc48c80d914cde inc/Module/Install/Fetch.pm SHA1 3e43ac0f1912c7d202dc102f6c31ad96fbf3a044 inc/Module/Install/Include.pm SHA1 76efdca3603159e0ae0e18f19fe72a0211a69529 inc/Module/Install/Makefile.pm SHA1 2e33e87882d60db3913da6284dd5295e5315e18a inc/Module/Install/Metadata.pm SHA1 c830b819e61bda5eca077c6291293bba61b3b9f2 inc/Module/Install/Win32.pm SHA1 cb52b9d6f88d512d448a6f35ed0af0d1201a134b inc/Module/Install/WriteAll.pm SHA1 653ebec88b7033eb8acb527abdd78a9c6b63b7fc lib/DBIx/SearchBuilder.pm SHA1 bc661f89d65e6a86aa1d55e57bc6b33084cf4c1c lib/DBIx/SearchBuilder/Handle.pm SHA1 55d337e6dd1ab5aecc39d2ae491bffb12e9ca449 lib/DBIx/SearchBuilder/Handle/Informix.pm SHA1 4efdcaefa5f94d994b052d1b343d2f5164ef4b52 lib/DBIx/SearchBuilder/Handle/ODBC.pm SHA1 1ace11fc43c5f90aa207740743f159053b7cc8b3 lib/DBIx/SearchBuilder/Handle/Oracle.pm SHA1 c575fb3f778fe9c5ac31661f9ce6f52b847d8a77 lib/DBIx/SearchBuilder/Handle/Pg.pm SHA1 7d0f133923bd66d4492e490fed981f562135c9a7 lib/DBIx/SearchBuilder/Handle/SQLite.pm SHA1 ec3fbc03b27c008d93a52b6b7fb0076529e5fcc8 lib/DBIx/SearchBuilder/Handle/Sybase.pm SHA1 3e7a6e7dd00dc59f9948288eb8235782ac2cd668 lib/DBIx/SearchBuilder/Handle/mysql.pm SHA1 877685aaff265e36fa37298c372aa56864f68aa5 lib/DBIx/SearchBuilder/Handle/mysqlPP.pm SHA1 665b010058702c1700a3a8d94cfc9f4f9b5fd385 lib/DBIx/SearchBuilder/Record.pm SHA1 4f58ebd740259da95e430d1f28ee9a887336a41f 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 25d794fce7a34c6b40470e1d347872d8d25df88a lib/DBIx/SearchBuilder/Util.pm SHA1 b7c82b550346f85678591966871bd47d6775bb70 t/00.load.t SHA1 a7ed1ee359ebe2842b354b5652a441403e802080 t/01basics.t SHA1 2b2dc6f72370f60e1d233f2f8c12bb87414e825c t/01nocap_api.t SHA1 09eb7ae878b679b38626e658ddebfd585825fdd4 t/01records.t SHA1 538891efe9f14014af62f6df441a7374aa8728b9 t/01searches.t SHA1 764771341b46b2da833ee2ddaa5c4d3191619e89 t/02distinct_values.t SHA1 3296f220370bb1bdb2ede3b0cfde9bed4e424f41 t/02null_order.t SHA1 af1f5d616e935cd955c2fb55c9595c8d35a3922c t/02order_outer.t SHA1 67d4c0dca9d1914eadba64460f3a2da4e074ae14 t/02records_cachable.t SHA1 446b8bab966c6456728caf0da4beb18c5cb0b835 t/02records_datetime.t SHA1 293dacc7cb7f39b9e48daea3b77f5dc325a84cbd t/02records_dt_interval.t SHA1 79ed9cd53a3851e87485d20b4803e8d4eaf21e48 t/02records_integers.t SHA1 6e50e77f1b54fe28fd6bcbb6eb104527f25d2601 t/02records_object.t SHA1 fb66ba9438525ae513f16187fa346ed881f30046 t/02searches_function.t SHA1 0838f9f0eef014ce70d9b4e6ede4ec50e32c83f6 t/02searches_joins.t SHA1 277100711a9adc634e2db7bc3701c7a927d689dc t/03compatibility.t SHA1 0402ef7097febffa2fa0d9afda56fbca122e49f9 t/03cud_from_select.t SHA1 fdc1ebd0353a4483f9a64a1b6558fd8c22b6a0e4 t/03rebless.t SHA1 81623a2abb738d1bc9b5a77355e0955dde401086 t/03transactions.t SHA1 1fe8ef579aa7e503f3227d42674c2218e4400ab5 t/03versions.t SHA1 f8f5634e7dc28068722347f47d7e05d06435e22c t/10schema.t SHA1 b22ee88495de953e688cda8d0959511864aa936b t/11schema_records.t SHA1 719a65f5712d16b06f46dfa3fc94485005e0b3d5 t/20set_edge_cases.t SHA1 e9c6a5881fc60173fbc8d479c1afd2ce3b43bef1 t/pod.t SHA1 afd320ea000cbe83b08691cc37bea45da20002d3 t/testmodels.pl SHA1 ceb2fad4e6973b7b30f0e83abc14cfb80ac93efe t/utils.pl -----BEGIN PGP SIGNATURE----- iQIcBAEBAgAGBQJXjSoWAAoJEDdW4lQxRAUgSpIP/1eYwaQxb7Ekh+CMpCINer7X Au3aqqtmQ7rKnfF9UZ9xIU18C/Y8KwgWMK989wQ+Rk5c594Yk3O+hj8lmiFB0fie z4gbO/nGydw1QqhiXdrJyq/u9n6hwPW1d2A80FOFfMdkUrjnFSGT6GXYFsORpU3T l3YY0iTHx3vsrJqFM6mkXnt/8Ois7taBRrazAl00fiwrgcSDDrxarsm2g4voVr47 A4zMnqgEO+wHDnOWrBl4VMagi1lffpFWdfTVTOeOxYueMtWxiOkbmcihXwEJz5A2 LhnkTnA0eadh03bjk5Hf8f2lK96NUgp84u11Gt3sBu65p/s1bpfFo8jkJ5ofhAzd GtMJUresq0CaFcwNOAHc8dFy25Ua4cavJdOMgosRfHKisoIblkfVQ9YL0OoRppb4 fAt8PH7UGJCfEyPN965itVlOxIMt2SYi+fyLsht81W5FFrbxjejz/srJd2SczMYN Snmi3jRp3SuDEB37zS+y7fMTXaWqApas8CYvPltCezIkne1PNcZ73JbdQFeKQItT 0SP1Q3UzGKHJBEnomLcjeM+qAFsYy8ITLZWpLXDu07SB3Cvjbpx2Tls+cwNDqo77 S1csuzKJMXbJwlDUXsr3IJH9RHfM0HdDPztdQl58tDDts6JE3Mt5T1HPObsGbqSJ w54s8BeQfNKlIZ1+sG2j =4Nr1 -----END PGP SIGNATURE----- DBIx-SearchBuilder-1.67/MANIFEST0000644000175000017500000000300612743225024015766 0ustar vagrantvagrant.gitignore Changes ex/create_tables.pl ex/Example/Model/Address.pm ex/Example/Model/Employee.pm inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/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 lib/DBIx/SearchBuilder/Util.pm Makefile.PL MANIFEST This list of files META.yml README ROADMAP SIGNATURE t/00.load.t t/01basics.t t/01nocap_api.t t/01records.t t/01searches.t t/02distinct_values.t t/02null_order.t t/02order_outer.t t/02records_cachable.t t/02records_datetime.t t/02records_dt_interval.t t/02records_integers.t t/02records_object.t t/02searches_function.t t/02searches_joins.t t/03compatibility.t t/03cud_from_select.t t/03rebless.t t/03transactions.t t/03versions.t t/10schema.t t/11schema_records.t t/20set_edge_cases.t t/pod.t t/testmodels.pl t/utils.pl DBIx-SearchBuilder-1.67/META.yml0000644000175000017500000000147312743225017016116 0ustar vagrantvagrant--- abstract: 'Encapsulate SQL queries and rows in simple perl objects' author: - 'Best Practical Solutions, LLC ' build_requires: DBD::SQLite: 0 ExtUtils::MakeMaker: 6.36 File::Temp: 0 Test::More: 0.52 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.16' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: DBIx-SearchBuilder no_index: directory: - ex - inc - t requires: Cache::Simple::TimedExpiry: '0.21' Class::Accessor: 0 Class::ReturnValue: 0.4 Clone: 0 DBI: 0 DBIx::DBSchema: 0 Encode: '1.99' Scalar::Util: 0 Want: 0 capitalization: '0.03' resources: license: http://dev.perl.org/licenses/ version: '1.67' DBIx-SearchBuilder-1.67/lib/0000755000175000017500000000000012743225026015406 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/lib/DBIx/0000755000175000017500000000000012743225026016174 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/lib/DBIx/SearchBuilder/0000755000175000017500000000000012743225026020710 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/lib/DBIx/SearchBuilder/Unique.pm0000644000175000017500000000320712740776544022533 0ustar vagrantvagrantpackage DBIx::SearchBuilder::Unique; use base 'Exporter'; our @EXPORT = qw(AddRecord); our $VERSION = "0.01"; use strict; use warnings; sub AddRecord { my $self = shift; my $record = shift; # We're a mixin, so we can't override _CleanSlate, but if an object # gets reused, we need to clean ourselves out. If there are no items, # we're clearly doing a new search $self->{"dbix_sb_unique_cache"} = {} unless (@{$self->{'items'}}[0]); return if $self->{"dbix_sb_unique_cache"}->{$record->id}++; push @{$self->{'items'}}, $record; } 1; =head1 NAME DBIx::SearchBuilder::Unique - Ensure uniqueness of records in a collection =head1 SYNOPSIS package Foo::Collection; use base 'DBIx::SearchBuilder'; use DBIx::SearchBuilder::Unique; # mixin my $collection = Foo::Collection->New(); $collection->SetupComplicatedJoins; $collection->OrderByMagic; while (my $thing = $collection->Next) { # $thing is going to be distinct } =head1 DESCRIPTION Currently, DBIx::SearchBuilder makes exceptions for databases which cannot handle both C =cut sub DatabaseVersion { my $self = shift; my %args = ( Short => 1, @_ ); unless ( defined $self->{'database_version'} ) { # turn off error handling, store old values to restore later my $re = $self->RaiseError; $self->RaiseError(0); my $pe = $self->PrintError; $self->PrintError(0); my $statement = "SELECT VERSION()"; my $sth = $self->SimpleQuery($statement); my $ver = ''; $ver = ( $sth->fetchrow_arrayref->[0] || '' ) if $sth; $ver =~ /(\d+(?:\.\d+)*(?:-[a-z0-9]+)?)/i; $self->{'database_version'} = $ver; $self->{'database_version_short'} = $1 || $ver; $self->RaiseError($re); $self->PrintError($pe); } return $self->{'database_version_short'} if $args{'Short'}; return $self->{'database_version'}; } =head2 CaseSensitive Returns 1 if the current database's searches are case sensitive by default Returns undef otherwise =cut sub CaseSensitive { my $self = shift; return(1); } =head2 _MakeClauseCaseInsensitive FIELD OPERATOR VALUE Takes a field, operator and value. performs the magic necessary to make your database treat this clause as case insensitive. Returns a FIELD OPERATOR VALUE triple. =cut our $RE_CASE_INSENSITIVE_CHARS = qr/[-'"\d: ]/; sub _MakeClauseCaseInsensitive { my $self = shift; my $field = shift; my $operator = shift; my $value = shift; # don't downcase integer values and things that looks like dates if ($value !~ /^$RE_CASE_INSENSITIVE_CHARS+$/o) { $field = "lower($field)"; $value = lc($value); } return ($field, $operator, $value,undef); } =head2 Transactions L emulates nested transactions, by keeping a transaction stack depth. B In nested transactions you shouldn't mix rollbacks and commits, because only last action really do commit/rollback. For example next code would produce desired results: $handle->BeginTransaction; $handle->BeginTransaction; ... $handle->Rollback; $handle->BeginTransaction; ... $handle->Commit; $handle->Commit; Only last action(Commit in example) finilize transaction in DB. =head3 BeginTransaction Tells DBIx::SearchBuilder to begin a new SQL transaction. This will temporarily suspend Autocommit mode. =cut sub BeginTransaction { my $self = shift; my $depth = $self->TransactionDepth; return unless defined $depth; $self->TransactionDepth(++$depth); return 1 if $depth > 1; return $self->dbh->begin_work; } =head3 EndTransaction [Action => 'commit'] [Force => 0] Tells to end the current transaction. Takes C argument that could be C or C, the default value is C. If C argument is true then all nested transactions would be committed or rolled back. If there is no transaction in progress then method throw warning unless action is forced. Method returns true on success or false if error occured. =cut sub EndTransaction { my $self = shift; my %args = ( Action => 'commit', Force => 0, @_ ); my $action = lc $args{'Action'} eq 'commit'? 'commit': 'rollback'; my $depth = $self->TransactionDepth || 0; unless ( $depth ) { unless( $args{'Force'} ) { Carp::cluck( "Attempted to $action a transaction with none in progress" ); return 0; } return 1; } else { $depth--; } $depth = 0 if $args{'Force'}; $self->TransactionDepth( $depth ); my $dbh = $self->dbh; $TRANSROLLBACK{ $dbh }{ $action }++; if ( $TRANSROLLBACK{ $dbh }{ $action eq 'commit'? 'rollback' : 'commit' } ) { warn "Rollback and commit are mixed while escaping nested transaction"; } return 1 if $depth; delete $TRANSROLLBACK{ $dbh }; if ($action eq 'commit') { return $dbh->commit; } else { DBIx::SearchBuilder::Record::Cachable->FlushCache if DBIx::SearchBuilder::Record::Cachable->can('FlushCache'); return $dbh->rollback; } } =head3 Commit [FORCE] Tells to commit the current SQL transaction. Method uses C method, read its L. =cut sub Commit { my $self = shift; $self->EndTransaction( Action => 'commit', Force => shift ); } =head3 Rollback [FORCE] Tells to abort the current SQL transaction. Method uses C method, read its L. =cut sub Rollback { my $self = shift; $self->EndTransaction( Action => 'rollback', Force => shift ); } =head3 ForceRollback Force the handle to rollback. Whether or not we're deep in nested transactions. =cut sub ForceRollback { my $self = shift; $self->Rollback(1); } =head3 TransactionDepth Returns the current depth of the nested transaction stack. Returns C if there is no connection to database. =cut sub TransactionDepth { my $self = shift; my $dbh = $self->dbh; return undef unless $dbh && $dbh->ping; if ( @_ ) { my $depth = shift; if ( $depth ) { $TRANSDEPTH{ $dbh } = $depth; } else { delete $TRANSDEPTH{ $dbh }; } } return $TRANSDEPTH{ $dbh } || 0; } =head2 ApplyLimits STATEMENTREF ROWS_PER_PAGE FIRST_ROW takes an SQL SELECT statement and massages it to return ROWS_PER_PAGE starting with FIRST_ROW; =cut sub ApplyLimits { my $self = shift; my $statementref = shift; my $per_page = shift; my $first = shift; my $limit_clause = ''; if ( $per_page) { $limit_clause = " LIMIT "; if ( $first ) { $limit_clause .= $first . ", "; } $limit_clause .= $per_page; } $$statementref .= $limit_clause; } =head2 Join { Paramhash } Takes a paramhash of everything Searchbuildler::Record does plus a parameter called 'SearchBuilder' that contains a ref to a SearchBuilder object'. This performs the join. =cut sub Join { my $self = shift; my %args = ( SearchBuilder => undef, TYPE => 'normal', ALIAS1 => 'main', FIELD1 => undef, TABLE2 => undef, COLLECTION2 => undef, FIELD2 => undef, ALIAS2 => undef, EXPRESSION => undef, @_ ); my $alias; #If we're handed in an ALIAS2, we need to go remove it from the Aliases array. # Basically, if anyone generates an alias and then tries to use it in a join later, we want to be smart about # creating joins, so we need to go rip it out of the old aliases table and drop it in as an explicit join if ( $args{'ALIAS2'} ) { # this code is slow and wasteful, but it's clear. my @aliases = @{ $args{'SearchBuilder'}->{'aliases'} }; my @new_aliases; foreach my $old_alias (@aliases) { if ( $old_alias =~ /^(.*?) (\Q$args{'ALIAS2'}\E)$/ ) { $args{'TABLE2'} = $1; $alias = $2; } else { push @new_aliases, $old_alias; } } # If we found an alias, great. let's just pull out the table and alias for the other item unless ($alias) { # if we can't do that, can we reverse the join and have it work? my $a1 = $args{'ALIAS1'}; my $f1 = $args{'FIELD1'}; $args{'ALIAS1'} = $args{'ALIAS2'}; $args{'FIELD1'} = $args{'FIELD2'}; $args{'ALIAS2'} = $a1; $args{'FIELD2'} = $f1; @aliases = @{ $args{'SearchBuilder'}->{'aliases'} }; @new_aliases = (); foreach my $old_alias (@aliases) { if ( $old_alias =~ /^(.*?) ($args{'ALIAS2'})$/ ) { $args{'TABLE2'} = $1; $alias = $2; } else { push @new_aliases, $old_alias; } } } else { # we found alias, so NewAlias should take care of distinctness $args{'DISTINCT'} = 1 unless exists $args{'DISTINCT'}; } unless ( $alias ) { # XXX: this situation is really bug in the caller!!! return ( $self->_NormalJoin(%args) ); } $args{'SearchBuilder'}->{'aliases'} = \@new_aliases; } elsif ( $args{'COLLECTION2'} ) { # We're joining to a pre-limited collection. We need to take # all clauses in the other collection, munge 'main.' to a new # alias, apply them locally, then proceed as usual. my $collection = delete $args{'COLLECTION2'}; $alias = $args{ALIAS2} = $args{'SearchBuilder'}->_GetAlias( $collection->Table ); $args{TABLE2} = $collection->Table; eval {$collection->_ProcessRestrictions}; # RT hate # Move over unused aliases push @{$args{SearchBuilder}{aliases}}, @{$collection->{aliases}}; # Move over joins, as well for my $join (sort keys %{$collection->{left_joins}}) { my %alias = %{$collection->{left_joins}{$join}}; $alias{depends_on} = $alias if $alias{depends_on} eq "main"; $alias{criteria} = $self->_RenameRestriction( RESTRICTIONS => $alias{criteria}, NEW => $alias ); $args{SearchBuilder}{left_joins}{$join} = \%alias; } my $restrictions = $self->_RenameRestriction( RESTRICTIONS => $collection->{restrictions}, NEW => $alias ); $args{SearchBuilder}{restrictions}{$_} = $restrictions->{$_} for keys %{$restrictions}; } else { $alias = $args{'SearchBuilder'}->_GetAlias( $args{'TABLE2'} ); } my $meta = $args{'SearchBuilder'}->{'left_joins'}{"$alias"} ||= {}; if ( $args{'TYPE'} =~ /LEFT/i ) { $meta->{'alias_string'} = " LEFT JOIN " . $args{'TABLE2'} . " $alias "; $meta->{'type'} = 'LEFT'; } else { $meta->{'alias_string'} = " JOIN " . $args{'TABLE2'} . " $alias "; $meta->{'type'} = 'NORMAL'; } $meta->{'depends_on'} = $args{'ALIAS1'}; my $criterion = $args{'EXPRESSION'} || $args{'ALIAS1'}.".".$args{'FIELD1'}; $meta->{'criteria'}{'base_criterion'} = [ { field => "$alias.$args{'FIELD2'}", op => '=', value => $criterion } ]; if ( $args{'DISTINCT'} && !defined $args{'SearchBuilder'}{'joins_are_distinct'} ) { $args{SearchBuilder}{joins_are_distinct} = 1; } elsif ( !$args{'DISTINCT'} ) { $args{SearchBuilder}{joins_are_distinct} = 0; } return ($alias); } sub _RenameRestriction { my $self = shift; my %args = ( RESTRICTIONS => undef, OLD => "main", NEW => undef, @_, ); my %return; for my $key ( keys %{$args{RESTRICTIONS}} ) { my $newkey = $key; $newkey =~ s/^\Q$args{OLD}\E\./$args{NEW}./; my @parts; for my $part ( @{ $args{RESTRICTIONS}{$key} } ) { if ( ref $part ) { my %part = %{$part}; $part{field} =~ s/^\Q$args{OLD}\E\./$args{NEW}./; $part{value} =~ s/^\Q$args{OLD}\E\./$args{NEW}./; push @parts, \%part; } else { push @parts, $part; } } $return{$newkey} = \@parts; } return \%return; } sub _NormalJoin { my $self = shift; my %args = ( SearchBuilder => undef, TYPE => 'normal', FIELD1 => undef, ALIAS1 => undef, TABLE2 => undef, FIELD2 => undef, ALIAS2 => undef, @_ ); my $sb = $args{'SearchBuilder'}; if ( $args{'TYPE'} =~ /LEFT/i ) { my $alias = $sb->_GetAlias( $args{'TABLE2'} ); my $meta = $sb->{'left_joins'}{"$alias"} ||= {}; $meta->{'alias_string'} = " LEFT JOIN $args{'TABLE2'} $alias "; $meta->{'depends_on'} = $args{'ALIAS1'}; $meta->{'type'} = 'LEFT'; $meta->{'criteria'}{'base_criterion'} = [ { field => "$args{'ALIAS1'}.$args{'FIELD1'}", op => '=', value => "$alias.$args{'FIELD2'}", } ]; return ($alias); } else { $sb->DBIx::SearchBuilder::Limit( ENTRYAGGREGATOR => 'AND', QUOTEVALUE => 0, ALIAS => $args{'ALIAS1'}, FIELD => $args{'FIELD1'}, VALUE => $args{'ALIAS2'} . "." . $args{'FIELD2'}, @_ ); } } # this code is all hacky and evil. but people desperately want _something_ and I'm # super tired. refactoring gratefully appreciated. sub _BuildJoins { my $self = shift; my $sb = shift; $self->OptimizeJoins( SearchBuilder => $sb ); my $join_clause = join " CROSS JOIN ", ($sb->Table ." main"), @{ $sb->{'aliases'} }; my %processed = map { /^\S+\s+(\S+)$/; $1 => 1 } @{ $sb->{'aliases'} }; $processed{'main'} = 1; # get a @list of joins that have not been processed yet, but depend on processed join my $joins = $sb->{'left_joins'}; while ( my @list = grep !$processed{ $_ } && (!$joins->{ $_ }{'depends_on'} || $processed{ $joins->{ $_ }{'depends_on'} }), sort keys %$joins ) { foreach my $join ( @list ) { $processed{ $join }++; my $meta = $joins->{ $join }; my $aggregator = $meta->{'entry_aggregator'} || 'AND'; $join_clause .= $meta->{'alias_string'} . " ON "; my @tmp = map { ref($_)? $_->{'field'} .' '. $_->{'op'} .' '. $_->{'value'}: $_ } map { ('(', @$_, ')', $aggregator) } sorted_values($meta->{'criteria'}); pop @tmp; $join_clause .= join ' ', @tmp; } } # here we could check if there is recursion in joins by checking that all joins # are processed if ( my @not_processed = grep !$processed{ $_ }, keys %$joins ) { die "Unsatisfied dependency chain in joins @not_processed"; } return $join_clause; } sub OptimizeJoins { my $self = shift; my %args = (SearchBuilder => undef, @_); my $joins = $args{'SearchBuilder'}->{'left_joins'}; my %processed = map { /^\S+\s+(\S+)$/; $1 => 1 } @{ $args{'SearchBuilder'}->{'aliases'} }; $processed{ $_ }++ foreach grep $joins->{ $_ }{'type'} ne 'LEFT', keys %$joins; $processed{'main'}++; my @ordered; # get a @list of joins that have not been processed yet, but depend on processed join # if we are talking about forest then we'll get the second level of the forest, # but we should process nodes on this level at the end, so we build FILO ordered list. # finally we'll get ordered list with leafes in the beginning and top most nodes at # the end. while ( my @list = grep !$processed{ $_ } && $processed{ $joins->{ $_ }{'depends_on'} }, sort keys %$joins ) { unshift @ordered, @list; $processed{ $_ }++ foreach @list; } foreach my $join ( @ordered ) { next if $self->MayBeNull( SearchBuilder => $args{'SearchBuilder'}, ALIAS => $join ); $joins->{ $join }{'alias_string'} =~ s/^\s*LEFT\s+/ /; $joins->{ $join }{'type'} = 'NORMAL'; } # here we could check if there is recursion in joins by checking that all joins # are processed } =head2 MayBeNull Takes a C and C in a hash and resturns true if restrictions of the query allow NULLs in a table joined with the ALIAS, otherwise returns false value which means that you can use normal join instead of left for the aliased table. Works only for queries have been built with L and L methods, for other cases return true value to avoid fault optimizations. =cut sub MayBeNull { my $self = shift; my %args = (SearchBuilder => undef, ALIAS => undef, @_); # if we have at least one subclause that is not generic then we should get out # of here as we can't parse subclauses return 1 if grep $_ ne 'generic_restrictions', keys %{ $args{'SearchBuilder'}->{'subclauses'} }; # build full list of generic conditions my @conditions; foreach ( grep @$_, sorted_values($args{'SearchBuilder'}->{'restrictions'}) ) { push @conditions, 'AND' if @conditions; push @conditions, '(', @$_, ')'; } # find tables that depends on this alias and add their join conditions foreach my $join ( sorted_values($args{'SearchBuilder'}->{'left_joins'}) ) { # left joins on the left side so later we'll get 1 AND x expression # which equal to x, so we just skip it next if $join->{'type'} eq 'LEFT'; next unless $join->{'depends_on'} eq $args{'ALIAS'}; my @tmp = map { ('(', @$_, ')', $join->{'entry_aggregator'}) } sorted_values($join->{'criteria'}); pop @tmp; @conditions = ('(', @conditions, ')', 'AND', '(', @tmp ,')'); } return 1 unless @conditions; # replace conditions with boolean result: 1 - allows nulls, 0 - not # all restrictions on that don't act on required alias allow nulls # otherwise only IS NULL operator foreach ( splice @conditions ) { unless ( ref $_ ) { push @conditions, $_; } elsif ( rindex( $_->{'field'}, "$args{'ALIAS'}.", 0 ) == 0 ) { # field is alias.xxx op ... and only IS op allows NULLs push @conditions, lc $_->{op} eq 'is'; } elsif ( $_->{'value'} && rindex( $_->{'value'}, "$args{'ALIAS'}.", 0 ) == 0 ) { # value is alias.xxx so it can not be IS op push @conditions, 0; } elsif ( $_->{'field'} =~ /^(?i:lower)\(\s*\Q$args{'ALIAS'}\./ ) { # handle 'LOWER(alias.xxx) OP VALUE' we use for case insensetive push @conditions, lc $_->{op} eq 'is'; } else { push @conditions, 1; } } # resturns index of closing paren by index of openning paren my $closing_paren = sub { my $i = shift; my $count = 0; for ( ; $i < @conditions; $i++ ) { if ( $conditions[$i] eq '(' ) { $count++; } elsif ( $conditions[$i] eq ')' ) { $count--; } return $i unless $count; } die "lost in parens"; }; # solve boolean expression we have, an answer is our result my $parens_count = 0; my @tmp = (); while ( defined ( my $e = shift @conditions ) ) { #print "@tmp >>>$e<<< @conditions\n"; return $e if !@conditions && !@tmp; unless ( $e ) { if ( $conditions[0] eq ')' ) { push @tmp, $e; next; } my $aggreg = uc shift @conditions; if ( $aggreg eq 'OR' ) { # 0 OR x == x next; } elsif ( $aggreg eq 'AND' ) { # 0 AND x == 0 my $close_p = $closing_paren->(0); splice @conditions, 0, $close_p + 1, (0); } else { die "unknown aggregator: @tmp $e >>>$aggreg<<< @conditions"; } } elsif ( $e eq '1' ) { if ( $conditions[0] eq ')' ) { push @tmp, $e; next; } my $aggreg = uc shift @conditions; if ( $aggreg eq 'OR' ) { # 1 OR x == 1 my $close_p = $closing_paren->(0); splice @conditions, 0, $close_p + 1, (1); } elsif ( $aggreg eq 'AND' ) { # 1 AND x == x next; } else { die "unknown aggregator: @tmp $e >>>$aggreg<<< @conditions"; } } elsif ( $e eq '(' ) { if ( $conditions[1] eq ')' ) { splice @conditions, 1, 1; } else { $parens_count++; push @tmp, $e; } } elsif ( $e eq ')' ) { die "extra closing paren: @tmp >>>$e<<< @conditions" if --$parens_count < 0; unshift @conditions, @tmp, $e; @tmp = (); } else { die "lost: @tmp >>>$e<<< @conditions"; } } return 1; } =head2 DistinctQuery STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; my $QueryHint = $sb->QueryHint; $QueryHint = $QueryHint ? " /* $QueryHint */ " : " "; # Prepend select query for DBs which allow DISTINCT on all column types. $$statementref = "SELECT" . $QueryHint . "DISTINCT main.* FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } =head2 DistinctCount STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctCount { my $self = shift; my $statementref = shift; my $sb = shift; my $QueryHint = $sb->QueryHint; $QueryHint = $QueryHint ? " /* $QueryHint */ " : " "; # Prepend select query for DBs which allow DISTINCT on all column types. $$statementref = "SELECT" . $QueryHint . "COUNT(DISTINCT main.id) FROM $$statementref"; } sub Fields { my $self = shift; my $table = lc shift; unless ( $FIELDS_IN_TABLE{$table} ) { $FIELDS_IN_TABLE{ $table } = []; my $sth = $self->dbh->column_info( undef, '', $table, '%' ) or return (); my $info = $sth->fetchall_arrayref({}); foreach my $e ( @$info ) { push @{ $FIELDS_IN_TABLE{ $table } }, $e->{'COLUMN_NAME'}; } } return @{ $FIELDS_IN_TABLE{ $table } }; } =head2 Log MESSAGE Takes a single argument, a message to log. Currently prints that message to STDERR =cut sub Log { my $self = shift; my $msg = shift; warn $msg."\n"; } =head2 SimpleDateTimeFunctions See L 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 for details. =back Returns SQL statement. Returns NULL if function is not supported. =head3 Supported functions Type value in L 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 => '', 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 DateTimeIntervalFunction Generates a function to calculate interval in seconds between two dates. Takes From and To arguments which can be either scalar or a hash. Hash is processed with L. Arguments are not quoted or escaped in any way. It's caller's job. =cut sub DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); $_ = DBIx::SearchBuilder->CombineFunctionWithField(%$_) for grep ref, @args{'From', 'To'}; return $self->_DateTimeIntervalFunction( %args ); } sub _DateTimeIntervalFunction { return 'NULL' } =head2 NullsOrder Sets order of NULLs when sorting columns when called with mode, but only if DB supports it. Modes: =over 4 =item * small NULLs are smaller then anything else, so come first when order is ASC and last otherwise. =item * large NULLs are larger then anything else. =item * first NULLs are always first. =item * last NULLs are always last. =item * default Return back to DB's default behaviour. =back When called without argument returns metadata required to generate SQL. =cut sub NullsOrder { my $self = shift; unless ($self->HasSupportForNullsOrder) { warn "No support for changing NULLs order" if @_; return undef; } if ( @_ ) { my $mode = shift || 'default'; if ( $mode eq 'default' ) { delete $self->{'nulls_order'}; } elsif ( $mode eq 'small' ) { $self->{'nulls_order'} = { ASC => 'NULLS FIRST', DESC => 'NULLS LAST' }; } elsif ( $mode eq 'large' ) { $self->{'nulls_order'} = { ASC => 'NULLS LAST', DESC => 'NULLS FIRST' }; } elsif ( $mode eq 'first' ) { $self->{'nulls_order'} = { ASC => 'NULLS FIRST', DESC => 'NULLS FIRST' }; } elsif ( $mode eq 'last' ) { $self->{'nulls_order'} = { ASC => 'NULLS LAST', DESC => 'NULLS LAST' }; } else { warn "'$mode' is not supported NULLs ordering mode"; delete $self->{'nulls_order'}; } } return undef unless $self->{'nulls_order'}; return $self->{'nulls_order'}; } =head2 HasSupportForNullsOrder Returns true value if DB supports adjusting NULLs order while sorting a column, for example C. =cut sub HasSupportForNullsOrder { return 0; } =head2 DESTROY When we get rid of the Searchbuilder::Handle, we need to disconnect from the database =cut sub DESTROY { my $self = shift; $self->Disconnect if $self->{'DisconnectHandleOnDestroy'}; delete $DBIHandle{$self}; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO perl(1), L =cut DBIx-SearchBuilder-1.67/lib/DBIx/SearchBuilder.pm0000755000175000017500000013666212743225014021264 0ustar vagrantvagrant package DBIx::SearchBuilder; use strict; use warnings; our $VERSION = "1.67"; use Clone qw(); use Encode qw(); use Scalar::Util qw(blessed); use DBIx::SearchBuilder::Util qw/ sorted_values /; =head1 NAME DBIx::SearchBuilder - Encapsulate SQL queries and rows in simple perl objects =head1 SYNOPSIS use DBIx::SearchBuilder; package My::Things; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->Table('Things'); return $self->SUPER::_Init(@_); } sub NewItem { my $self = shift; # MyThing is a subclass of DBIx::SearchBuilder::Record return(MyThing->new); } package main; use DBIx::SearchBuilder::Handle; my $handle = DBIx::SearchBuilder::Handle->new(); $handle->Connect( Driver => 'SQLite', Database => "my_test_db" ); my $sb = My::Things->new( Handle => $handle ); $sb->Limit( FIELD => "column_1", VALUE => "matchstring" ); while ( my $record = $sb->Next ) { print $record->my_column_name(); } =head1 DESCRIPTION This module provides an object-oriented mechanism for retrieving and updating data in a DBI-accesible database. In order to use this module, you should create a subclass of C and a subclass of C for each table that you wish to access. (See the documentation of C for more information on subclassing it.) Your C subclass must override C, and probably should override at least C<_Init> also; at the very least, C<_Init> should probably call C<_Handle> and C<_Table> to set the database handle (a C object) and table name for the class. You can try to override just about every other method here, as long as you think you know what you are doing. =head1 METHOD NAMING Each method has a lower case alias; '_' is used to separate words. For example, the method C has the alias C. =head1 METHODS =cut =head2 new Creates a new SearchBuilder object and immediately calls C<_Init> with the same parameters that were passed to C. If you haven't overridden C<_Init> in your subclass, this means that you should pass in a C (or one of its subclasses) like this: my $sb = My::DBIx::SearchBuilder::Subclass->new( Handle => $handle ); However, if your subclass overrides _Init you do not need to take a Handle argument, as long as your subclass returns an appropriate handle object from the C<_Handle> method. This is useful if you want all of your SearchBuilder objects to use a shared global handle and don't want to have to explicitly pass it in each time, for example. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless( $self, $class ); $self->_Init(@_); return ($self); } =head2 _Init This method is called by C with whatever arguments were passed to C. By default, it takes a C object as a C argument, although this is not necessary if your subclass overrides C<_Handle>. =cut sub _Init { my $self = shift; my %args = ( Handle => undef, @_ ); $self->_Handle( $args{'Handle'} ); $self->CleanSlate(); } =head2 CleanSlate This completely erases all the data in the SearchBuilder object. It's useful if a subclass is doing funky stuff to keep track of a search and wants to reset the SearchBuilder data without losing its own data; it's probably cleaner to accomplish that in a different way, though. =cut sub CleanSlate { my $self = shift; $self->RedoSearch(); $self->{'itemscount'} = 0; $self->{'limit_clause'} = ""; $self->{'order'} = ""; $self->{'alias_count'} = 0; $self->{'first_row'} = 0; $self->{'must_redo_search'} = 1; $self->{'show_rows'} = 0; $self->{'joins_are_distinct'} = undef; @{ $self->{'aliases'} } = (); delete $self->{$_} for qw( items left_joins raw_rows count_all subclauses restrictions _open_parens _close_parens group_by columns query_hint ); #we have no limit statements. DoSearch won't work. $self->_isLimited(0); } =head2 Clone Returns copy of the current object with all search restrictions. =cut sub Clone { my $self = shift; my $obj = bless {}, ref($self); %$obj = %$self; delete $obj->{$_} for qw( items ); $obj->{'must_redo_search'} = 1; $obj->{'itemscount'} = 0; $obj->{ $_ } = Clone::clone( $obj->{ $_ } ) foreach grep exists $self->{ $_ }, $self->_ClonedAttributes; return $obj; } =head2 _ClonedAttributes Returns list of the object's fields that should be copied. If your subclass store references in the object that should be copied while clonning then you probably want override this method and add own values to the list. =cut sub _ClonedAttributes { return qw( aliases left_joins subclauses restrictions order_by group_by columns query_hint ); } =head2 _Handle [DBH] Get or set this object's DBIx::SearchBuilder::Handle object. =cut sub _Handle { my $self = shift; if (@_) { $self->{'DBIxHandle'} = shift; } return ( $self->{'DBIxHandle'} ); } =head2 _DoSearch This internal private method actually executes the search on the database; it is called automatically the first time that you actually need results (such as a call to C). =cut sub _DoSearch { my $self = shift; my $QueryString = $self->BuildSelectQuery(); # If we're about to redo the search, we need an empty set of items and a reset iterator delete $self->{'items'}; $self->{'itemscount'} = 0; my $records = $self->_Handle->SimpleQuery($QueryString); return 0 unless $records; while ( my $row = $records->fetchrow_hashref() ) { my $item = $self->NewItem(); $item->LoadFromHash($row); $self->AddRecord($item); } return $self->_RecordCount if $records->err; $self->{'must_redo_search'} = 0; return $self->_RecordCount; } =head2 AddRecord RECORD Adds a record object to this collection. =cut sub AddRecord { my $self = shift; my $record = shift; push @{$self->{'items'}}, $record; } =head2 _RecordCount This private internal method returns the number of Record objects saved as a result of the last query. =cut sub _RecordCount { my $self = shift; return 0 unless defined $self->{'items'}; return scalar @{ $self->{'items'} }; } =head2 _DoCount This internal private method actually executes a counting operation on the database; it is used by C and C. =cut sub _DoCount { my $self = shift; my $all = shift || 0; my $QueryString = $self->BuildSelectCountQuery(); my $records = $self->_Handle->SimpleQuery($QueryString); return 0 unless $records; my @row = $records->fetchrow_array(); return 0 if $records->err; $self->{ $all ? 'count_all' : 'raw_rows' } = $row[0]; return ( $row[0] ); } =head2 _ApplyLimits STATEMENTREF This routine takes a reference to a scalar containing an SQL statement. It massages the statement to limit the returned rows to only C<< $self->RowsPerPage >> rows, skipping C<< $self->FirstRow >> rows. (That is, if rows are numbered starting from 0, row number C<< $self->FirstRow >> will be the first row returned.) Note that it probably makes no sense to set these variables unless you are also enforcing an ordering on the rows (with C, say). =cut sub _ApplyLimits { my $self = shift; my $statementref = shift; $self->_Handle->ApplyLimits($statementref, $self->RowsPerPage, $self->FirstRow); $$statementref =~ s/main\.\*/join(', ', @{$self->{columns}})/eg if $self->{columns} and @{$self->{columns}}; } =head2 _DistinctQuery STATEMENTREF This routine takes a reference to a scalar containing an SQL statement. It massages the statement to ensure a distinct result set is returned. =cut sub _DistinctQuery { my $self = shift; my $statementref = shift; # XXX - Postgres gets unhappy with distinct and OrderBy aliases $self->_Handle->DistinctQuery($statementref, $self) } =head2 _BuildJoins Build up all of the joins we need to perform this query. =cut sub _BuildJoins { my $self = shift; return ( $self->_Handle->_BuildJoins($self) ); } =head2 _isJoined Returns true if this SearchBuilder will be joining multiple tables together. =cut sub _isJoined { my $self = shift; if ( keys %{ $self->{'left_joins'} } ) { return (1); } else { return (@{ $self->{'aliases'} }); } } # LIMIT clauses are used for restricting ourselves to subsets of the search. sub _LimitClause { my $self = shift; my $limit_clause; if ( $self->RowsPerPage ) { $limit_clause = " LIMIT "; if ( $self->FirstRow != 0 ) { $limit_clause .= $self->FirstRow . ", "; } $limit_clause .= $self->RowsPerPage; } else { $limit_clause = ""; } return $limit_clause; } =head2 _isLimited If we've limited down this search, return true. Otherwise, return false. =cut sub _isLimited { my $self = shift; if (@_) { $self->{'is_limited'} = shift; } else { return ( $self->{'is_limited'} ); } } =head2 BuildSelectQuery Builds a query string for a "SELECT rows from Tables" statement for this SearchBuilder object =cut sub BuildSelectQuery { my $self = shift; # The initial SELECT or SELECT DISTINCT is decided later my $QueryString = $self->_BuildJoins . " "; $QueryString .= $self->_WhereClause . " " if ( $self->_isLimited > 0 ); my $QueryHint = $self->QueryHintFormatted; # DISTINCT query only required for multi-table selects # when we have group by clause then the result set is distinct as # it must contain only columns we group by or results of aggregate # functions which give one result per group, so we can skip DISTINCTing if ( my $clause = $self->_GroupClause ) { $QueryString = "SELECT" . $QueryHint . "main.* FROM $QueryString"; $QueryString .= $clause; $QueryString .= $self->_OrderClause; } elsif ( !$self->{'joins_are_distinct'} && $self->_isJoined ) { $self->_DistinctQuery(\$QueryString); } else { $QueryString = "SELECT" . $QueryHint . "main.* FROM $QueryString"; $QueryString .= $self->_OrderClause; } $self->_ApplyLimits(\$QueryString); return($QueryString) } =head2 BuildSelectCountQuery Builds a SELECT statement to find the number of rows this SearchBuilder object would find. =cut sub BuildSelectCountQuery { my $self = shift; #TODO refactor DoSearch and DoCount such that we only have # one place where we build most of the querystring my $QueryString = $self->_BuildJoins . " "; $QueryString .= $self->_WhereClause . " " if ( $self->_isLimited > 0 ); # DISTINCT query only required for multi-table selects if ($self->_isJoined) { $QueryString = $self->_Handle->DistinctCount(\$QueryString, $self); } else { my $QueryHint = $self->QueryHintFormatted; $QueryString = "SELECT" . $QueryHint . "count(main.id) FROM " . $QueryString; } return ($QueryString); } =head2 Next Returns the next row from the set as an object of the type defined by sub NewItem. When the complete set has been iterated through, returns undef and resets the search such that the following call to Next will start over with the first item retrieved from the database. =cut sub Next { my $self = shift; my @row; return (undef) unless ( $self->_isLimited ); $self->_DoSearch() if $self->{'must_redo_search'}; if ( $self->{'itemscount'} < $self->_RecordCount ) { #return the next item my $item = ( $self->{'items'}[ $self->{'itemscount'} ] ); $self->{'itemscount'}++; return ($item); } else { #we've gone through the whole list. reset the count. $self->GotoFirstItem(); return (undef); } } =head2 GotoFirstItem Starts the recordset counter over from the first item. The next time you call Next, you'll get the first item returned by the database, as if you'd just started iterating through the result set. =cut sub GotoFirstItem { my $self = shift; $self->GotoItem(0); } =head2 GotoItem Takes an integer N and sets the record iterator to N. The first time L is called afterwards, it will return the Nth item found by the search. You should only call GotoItem after you've already fetched at least one result or otherwise forced the search query to run (such as via L). If GotoItem is called before the search query is ever run, it will reset the item iterator and L will return the L item. =cut sub GotoItem { my $self = shift; my $item = shift; $self->{'itemscount'} = $item; } =head2 First Returns the first item =cut sub First { my $self = shift; $self->GotoFirstItem(); return ( $self->Next ); } =head2 Last Returns the last item =cut sub Last { my $self = shift; $self->_DoSearch if $self->{'must_redo_search'}; $self->GotoItem( ( $self->Count ) - 1 ); return ( $self->Next ); } =head2 DistinctFieldValues Returns list with distinct values of field. Limits on collection are accounted, so collection should be Led to get values from the whole table. Takes paramhash with the following keys: =over 4 =item Field Field name. Can be first argument without key. =item Order 'ASC', 'DESC' or undef. Defines whether results should be sorted or not. By default results are not sorted. =item Max Maximum number of elements to fetch. =back =cut sub DistinctFieldValues { my $self = shift; my %args = ( Field => undef, Order => undef, Max => undef, @_%2 ? (Field => @_) : (@_) ); my $query_string = $self->_BuildJoins; $query_string .= ' '. $self->_WhereClause if $self->_isLimited > 0; my $query_hint = $self->QueryHintFormatted; my $column = 'main.'. $args{'Field'}; $query_string = "SELECT" . $query_hint . "DISTINCT $column FROM $query_string"; if ( $args{'Order'} ) { $query_string .= ' ORDER BY '. $column .' '. ($args{'Order'} =~ /^des/i ? 'DESC' : 'ASC'); } my $dbh = $self->_Handle->dbh; my $list = $dbh->selectcol_arrayref( $query_string, { MaxRows => $args{'Max'} } ); return $list? @$list : (); } =head2 ItemsArrayRef Return a refernece to an array containing all objects found by this search. =cut sub ItemsArrayRef { my $self = shift; #If we're not limited, return an empty array return [] unless $self->_isLimited; #Do a search if we need to. $self->_DoSearch() if $self->{'must_redo_search'}; #If we've got any items in the array, return them. # Otherwise, return an empty array return ( $self->{'items'} || [] ); } =head2 NewItem NewItem must be subclassed. It is used by DBIx::SearchBuilder to create record objects for each row returned from the database. =cut sub NewItem { my $self = shift; die "DBIx::SearchBuilder needs to be subclassed. you can't use it directly.\n"; } =head2 RedoSearch Takes no arguments. Tells DBIx::SearchBuilder that the next time it's asked for a record, it should requery the database =cut sub RedoSearch { my $self = shift; $self->{'must_redo_search'} = 1; } =head2 UnLimit UnLimit clears all restrictions and causes this object to return all rows in the primary table. =cut sub UnLimit { my $self = shift; $self->_isLimited(-1); } =head2 Limit Limit takes a hash of parameters with the following keys: =over 4 =item TABLE Can be set to something different than this table if a join is wanted (that means we can't do recursive joins as for now). =item ALIAS Unless ALIAS is set, the join criterias will be taken from EXT_LINKFIELD and INT_LINKFIELD and added to the criterias. If ALIAS is set, new criterias about the foreign table will be added. =item LEFTJOIN To apply the Limit inside the ON clause of a previously created left join, pass this option along with the alias returned from creating the left join. ( This is similar to using the EXPRESSION option when creating a left join but this allows you to refer to the join alias in the expression. ) =item FIELD Column to be checked against. =item FUNCTION Function that should be checked against or applied to the FIELD before check. See L for rules. =item VALUE Should always be set and will always be quoted. =item OPERATOR OPERATOR is the SQL operator to use for this phrase. Possible choices include: =over 4 =item "=" =item "!=" =item "LIKE" In the case of LIKE, the string is surrounded in % signs. Yes. this is a bug. =item "NOT LIKE" =item "STARTSWITH" STARTSWITH is like LIKE, except it only appends a % at the end of the string =item "ENDSWITH" ENDSWITH is like LIKE, except it prepends a % to the beginning of the string =item "MATCHES" MATCHES is equivalent to the database's LIKE -- that is, it's actually LIKE, but doesn't surround the string in % signs as LIKE does. =item "IN" and "NOT IN" VALUE can be an array reference or an object inherited from this class. If it's not then it's treated as any other operator and in most cases SQL would be wrong. Values in array are considered as constants and quoted according to QUOTEVALUE. If object is passed as VALUE then its select statement is used. If no L is selected then C is used, if more than one selected then warning is issued and first column is used. =back =item ENTRYAGGREGATOR Can be C or C (or anything else valid to aggregate two clauses in SQL). Special value is C which means that no entry aggregator should be used. The default value is C. =item CASESENSITIVE on some databases, such as postgres, setting CASESENSITIVE to 1 will make this search case sensitive =item SUBCLAUSE Subclause allows you to assign tags to Limit statements. Statements with matching SUBCLAUSE tags will be grouped together in the final SQL statement. Example: Suppose you want to create Limit statments which would produce results the same as the following SQL: SELECT * FROM Users WHERE EmailAddress OR Name OR RealName OR Email LIKE $query; You would use the following Limit statements: $folks->Limit( FIELD => 'EmailAddress', OPERATOR => 'LIKE', VALUE => "$query", SUBCLAUSE => 'groupsearch'); $folks->Limit( FIELD => 'Name', OPERATOR => 'LIKE', VALUE => "$query", SUBCLAUSE => 'groupsearch'); $folks->Limit( FIELD => 'RealName', OPERATOR => 'LIKE', VALUE => "$query", SUBCLAUSE => 'groupsearch'); =back =cut sub Limit { my $self = shift; my %args = ( TABLE => $self->Table, ALIAS => undef, FIELD => undef, FUNCTION => undef, VALUE => undef, QUOTEVALUE => 1, ENTRYAGGREGATOR => undef, CASESENSITIVE => undef, OPERATOR => '=', SUBCLAUSE => undef, LEFTJOIN => undef, @_ # get the real argumentlist ); unless ( $args{'ENTRYAGGREGATOR'} ) { if ( $args{'LEFTJOIN'} ) { $args{'ENTRYAGGREGATOR'} = 'AND'; } else { $args{'ENTRYAGGREGATOR'} = 'OR'; } } #since we're changing the search criteria, we need to redo the search $self->RedoSearch(); if ( $args{'OPERATOR'} ) { #If it's a like, we supply the %s around the search term if ( $args{'OPERATOR'} =~ /LIKE/i ) { $args{'VALUE'} = "%" . $args{'VALUE'} . "%"; } elsif ( $args{'OPERATOR'} =~ /STARTSWITH/i ) { $args{'VALUE'} = $args{'VALUE'} . "%"; } elsif ( $args{'OPERATOR'} =~ /ENDSWITH/i ) { $args{'VALUE'} = "%" . $args{'VALUE'}; } elsif ( $args{'OPERATOR'} =~ /\bIN$/i ) { if ( blessed $args{'VALUE'} && $args{'VALUE'}->isa(__PACKAGE__) ) { # if no columns selected then select id local $args{'VALUE'}{'columns'} = $args{'VALUE'}{'columns'}; unless ( $args{'VALUE'}{'columns'} ) { $args{'VALUE'}->Column( FIELD => 'id' ); } elsif ( @{ $args{'VALUE'}{'columns'} } > 1 ) { warn "Collection in '$args{OPERATOR}' with more than one column selected, using first"; splice @{ $args{'VALUE'}{'columns'} }, 1; } $args{'VALUE'} = '('. $args{'VALUE'}->BuildSelectQuery .')'; $args{'QUOTEVALUE'} = 0; } elsif ( ref $args{'VALUE'} ) { if ( $args{'QUOTEVALUE'} ) { my $dbh = $self->_Handle->dbh; $args{'VALUE'} = join ', ', map $dbh->quote( $_ ), @{ $args{'VALUE'} }; } else { $args{'VALUE'} = join ', ', @{ $args{'VALUE'} }; } $args{'VALUE'} = "($args{VALUE})"; $args{'QUOTEVALUE'} = 0; } else { # otherwise behave in backwards compatible way } } $args{'OPERATOR'} =~ s/(?:MATCHES|ENDSWITH|STARTSWITH)/LIKE/i; if ( $args{'OPERATOR'} =~ /IS/i ) { $args{'VALUE'} = 'NULL'; $args{'QUOTEVALUE'} = 0; } } if ( $args{'QUOTEVALUE'} ) { #if we're explicitly told not to to quote the value or # we're doing an IS or IS NOT (null), don't quote the operator. $args{'VALUE'} = $self->_Handle->dbh->quote( $args{'VALUE'} ); } my $Alias = $self->_GenericRestriction(%args); warn "No table alias set!" unless $Alias; # We're now limited. people can do searches. $self->_isLimited(1); if ( defined($Alias) ) { return ($Alias); } else { return (1); } } sub _GenericRestriction { my $self = shift; my %args = ( TABLE => $self->Table, FIELD => undef, FUNCTION => undef, VALUE => undef, ALIAS => undef, LEFTJOIN => undef, ENTRYAGGREGATOR => undef, OPERATOR => '=', SUBCLAUSE => undef, CASESENSITIVE => undef, QUOTEVALUE => undef, @_ ); #TODO: $args{'VALUE'} should take an array of values and generate # the proper where clause. #If we're performing a left join, we really want the alias to be the #left join criterion. if ( defined $args{'LEFTJOIN'} && !defined $args{'ALIAS'} ) { $args{'ALIAS'} = $args{'LEFTJOIN'}; } # if there's no alias set, we need to set it unless ( $args{'ALIAS'} ) { #if the table we're looking at is the same as the main table if ( $args{'TABLE'} eq $self->Table ) { # TODO this code assumes no self joins on that table. # if someone can name a case where we'd want to do that, # I'll change it. $args{'ALIAS'} = 'main'; } # if we're joining, we need to work out the table alias else { $args{'ALIAS'} = $self->NewAlias( $args{'TABLE'} ); } } # Set this to the name of the field and the alias, unless we've been # handed a subclause name my $ClauseId = $args{'SUBCLAUSE'} || ($args{'ALIAS'} . "." . $args{'FIELD'}); # If we're trying to get a leftjoin restriction, lets set # $restriction to point htere. otherwise, lets construct normally my $restriction; if ( $args{'LEFTJOIN'} ) { if ( $args{'ENTRYAGGREGATOR'} ) { $self->{'left_joins'}{ $args{'LEFTJOIN'} }{'entry_aggregator'} = $args{'ENTRYAGGREGATOR'}; } $restriction = $self->{'left_joins'}{ $args{'LEFTJOIN'} }{'criteria'}{ $ClauseId } ||= []; } else { $restriction = $self->{'restrictions'}{ $ClauseId } ||= []; } my $QualifiedField = $self->CombineFunctionWithField( %args ); # If it's a new value or we're overwriting this sort of restriction, if ( $self->_Handle->CaseSensitive && defined $args{'VALUE'} && $args{'VALUE'} ne '' && $args{'VALUE'} ne "''" && ($args{'OPERATOR'} !~/IS/ && $args{'VALUE'} !~ /^null$/i)) { unless ( $args{'CASESENSITIVE'} || !$args{'QUOTEVALUE'} ) { ( $QualifiedField, $args{'OPERATOR'}, $args{'VALUE'} ) = $self->_Handle->_MakeClauseCaseInsensitive( $QualifiedField, $args{'OPERATOR'}, $args{'VALUE'} ); } } my $clause = { field => $QualifiedField, op => $args{'OPERATOR'}, value => $args{'VALUE'}, }; # Juju because this should come _AFTER_ the EA my @prefix; if ( $self->{_open_parens}{ $ClauseId } ) { @prefix = ('(') x delete $self->{_open_parens}{ $ClauseId }; } if ( lc( $args{'ENTRYAGGREGATOR'} || "" ) eq 'none' || !@$restriction ) { @$restriction = (@prefix, $clause); } else { push @$restriction, $args{'ENTRYAGGREGATOR'}, @prefix, $clause; } return ( $args{'ALIAS'} ); } sub _OpenParen { my ($self, $clause) = @_; $self->{_open_parens}{ $clause }++; } # Immediate Action sub _CloseParen { my ( $self, $clause ) = @_; my $restriction = ($self->{'restrictions'}{ $clause } ||= []); push @$restriction, ')'; } sub _AddSubClause { my $self = shift; my $clauseid = shift; my $subclause = shift; $self->{'subclauses'}{ $clauseid } = $subclause; } sub _WhereClause { my $self = shift; #Go through all the generic restrictions and build up the "generic_restrictions" subclause # That's the only one that SearchBuilder builds itself. # Arguably, the abstraction should be better, but I don't really see where to put it. $self->_CompileGenericRestrictions(); #Go through all restriction types. Build the where clause from the #Various subclauses. my $where_clause = ''; foreach my $subclause ( grep $_, sorted_values($self->{'subclauses'}) ) { $where_clause .= " AND " if $where_clause; $where_clause .= $subclause; } $where_clause = " WHERE " . $where_clause if $where_clause; return ($where_clause); } #Compile the restrictions to a WHERE Clause sub _CompileGenericRestrictions { my $self = shift; my $result = ''; #Go through all the restrictions of this type. Buld up the generic subclause foreach my $restriction ( grep @$_, sorted_values($self->{'restrictions'}) ) { $result .= " AND " if $result; $result .= '('; foreach my $entry ( @$restriction ) { unless ( ref $entry ) { $result .= ' '. $entry . ' '; } else { $result .= join ' ', @{$entry}{qw(field op value)}; } } $result .= ')'; } return ($self->{'subclauses'}{'generic_restrictions'} = $result); } =head2 OrderBy PARAMHASH Orders the returned results by ALIAS.FIELD ORDER. Takes a paramhash of ALIAS, FIELD and ORDER. ALIAS defaults to C
. FIELD has no default value. ORDER defaults to ASC(ending). DESC(ending) is also a valid value for OrderBy. FIELD also accepts C format. =cut sub OrderBy { my $self = shift; $self->OrderByCols( { @_ } ); } =head2 OrderByCols ARRAY OrderByCols takes an array of paramhashes of the form passed to OrderBy. The result set is ordered by the items in the array. =cut sub OrderByCols { my $self = shift; my @args = @_; $self->{'order_by'} = \@args; $self->RedoSearch(); } =head2 _OrderClause returns the ORDER BY clause for the search. =cut sub _OrderClause { my $self = shift; return '' unless $self->{'order_by'}; my $nulls_order = $self->_Handle->NullsOrder; my $clause = ''; foreach my $row ( @{$self->{'order_by'}} ) { my %rowhash = ( ALIAS => 'main', FIELD => undef, ORDER => 'ASC', %$row ); if ($rowhash{'ORDER'} && $rowhash{'ORDER'} =~ /^des/i) { $rowhash{'ORDER'} = "DESC"; $rowhash{'ORDER'} .= ' '. $nulls_order->{'DESC'} if $nulls_order; } else { $rowhash{'ORDER'} = "ASC"; $rowhash{'ORDER'} .= ' '. $nulls_order->{'ASC'} if $nulls_order; } $rowhash{'ALIAS'} = 'main' unless defined $rowhash{'ALIAS'}; if ( defined $rowhash{'ALIAS'} and $rowhash{'FIELD'} and $rowhash{'ORDER'} ) { if ( length $rowhash{'ALIAS'} && $rowhash{'FIELD'} =~ /^(\w+\()(.*\))$/ ) { # handle 'FUNCTION(FIELD)' formatted fields $rowhash{'ALIAS'} = $1 . $rowhash{'ALIAS'}; $rowhash{'FIELD'} = $2; } $clause .= ($clause ? ", " : " "); $clause .= $rowhash{'ALIAS'} . "." if length $rowhash{'ALIAS'}; $clause .= $rowhash{'FIELD'} . " "; $clause .= $rowhash{'ORDER'}; } } $clause = " ORDER BY$clause " if $clause; return $clause; } =head2 GroupByCols ARRAY_OF_HASHES Each hash contains the keys FIELD, FUNCTION and ALIAS. Hash combined into SQL with L. =cut sub GroupByCols { my $self = shift; my @args = @_; $self->{'group_by'} = \@args; $self->RedoSearch(); } =head2 _GroupClause Private function to return the "GROUP BY" clause for this query. =cut sub _GroupClause { my $self = shift; return '' unless $self->{'group_by'}; my $clause = ''; foreach my $row ( @{$self->{'group_by'}} ) { my $part = $self->CombineFunctionWithField( %$row ) or next; $clause .= ', ' if $clause; $clause .= $part; } return '' unless $clause; return " GROUP BY $clause "; } =head2 NewAlias Takes the name of a table and paramhash with TYPE and DISTINCT. Use TYPE equal to C to indicate that it's LEFT JOIN. Old style way to call (see below) is also supported, but should be B: $records->NewAlias('aTable', 'left'); True DISTINCT value indicates that this join keeps result set distinct and DB side distinct is not required. See also L. Returns the string of a new Alias for that table, which can be used to Join tables or to Limit what gets found by a search. =cut sub NewAlias { my $self = shift; my $table = shift || die "Missing parameter"; my %args = @_%2? (TYPE => @_) : (@_); my $type = $args{'TYPE'}; my $alias = $self->_GetAlias($table); unless ( $type ) { push @{ $self->{'aliases'} }, "$table $alias"; } elsif ( lc $type eq 'left' ) { my $meta = $self->{'left_joins'}{"$alias"} ||= {}; $meta->{'alias_string'} = " LEFT JOIN $table $alias "; $meta->{'type'} = 'LEFT'; $meta->{'depends_on'} = ''; } else { die "Unsupported alias(join) type"; } if ( $args{'DISTINCT'} && !defined $self->{'joins_are_distinct'} ) { $self->{'joins_are_distinct'} = 1; } elsif ( !$args{'DISTINCT'} ) { $self->{'joins_are_distinct'} = 0; } return $alias; } # _GetAlias is a private function which takes an tablename and # returns a new alias for that table without adding something # to self->{'aliases'}. This function is used by NewAlias # and the as-yet-unnamed left join code sub _GetAlias { my $self = shift; my $table = shift; $self->{'alias_count'}++; my $alias = $table . "_" . $self->{'alias_count'}; return ($alias); } =head2 Join Join instructs DBIx::SearchBuilder to join two tables. The standard form takes a param hash with keys ALIAS1, FIELD1, ALIAS2 and FIELD2. ALIAS1 and ALIAS2 are column aliases obtained from $self->NewAlias or a $self->Limit. FIELD1 and FIELD2 are the fields in ALIAS1 and ALIAS2 that should be linked, respectively. For this type of join, this method has no return value. Supplying the parameter TYPE => 'left' causes Join to preform a left join. in this case, it takes ALIAS1, FIELD1, TABLE2 and FIELD2. Because of the way that left joins work, this method needs a TABLE for the second field rather than merely an alias. For this type of join, it will return the alias generated by the join. Instead of ALIAS1/FIELD1, it's possible to specify EXPRESSION, to join ALIAS2/TABLE2 on an arbitrary expression. It is also possible to join to a pre-existing, already-limited L object, by passing it as COLLECTION2, instead of providing an ALIAS2 or TABLE2. By passing true value as DISTINCT argument join can be marked distinct. If all joins are distinct then whole query is distinct and SearchBuilder can avoid L call that can hurt performance of the query. See also L. =cut sub Join { my $self = shift; my %args = ( TYPE => 'normal', FIELD1 => undef, ALIAS1 => 'main', TABLE2 => undef, COLLECTION2 => undef, FIELD2 => undef, ALIAS2 => undef, @_ ); $self->_Handle->Join( SearchBuilder => $self, %args ); } =head2 Pages: size and changing Use L to set size of pages. L, L, L or L to change pages. L to do tricky stuff. =head3 RowsPerPage Get or set the number of rows returned by the database. Takes an optional integer which restricts the # of rows returned in a result. Zero or undef argument flush back to "return all records matching current conditions". Returns the current page size. =cut sub RowsPerPage { my $self = shift; if ( @_ && ($_[0]||0) != $self->{'show_rows'} ) { $self->{'show_rows'} = shift || 0; $self->RedoSearch; } return ( $self->{'show_rows'} ); } =head3 NextPage Turns one page forward. =cut sub NextPage { my $self = shift; $self->FirstRow( $self->FirstRow + 1 + $self->RowsPerPage ); } =head3 PrevPage Turns one page backwards. =cut sub PrevPage { my $self = shift; if ( ( $self->FirstRow - $self->RowsPerPage ) > 0 ) { $self->FirstRow( 1 + $self->FirstRow - $self->RowsPerPage ); } else { $self->FirstRow(1); } } =head3 FirstPage Jumps to the first page. =cut sub FirstPage { my $self = shift; $self->FirstRow(1); } =head3 GotoPage Takes an integer number and jumps to that page or first page if number omitted. Numbering starts from zero. =cut sub GotoPage { my $self = shift; my $page = shift || 0; $self->FirstRow( 1 + $self->RowsPerPage * $page ); } =head3 FirstRow Get or set the first row of the result set the database should return. Takes an optional single integer argrument. Returns the currently set integer minus one (this is historical issue). Usually you don't need this method. Use L, L and other methods to walk pages. It only may be helpful to get 10 records starting from 5th. =cut sub FirstRow { my $self = shift; if (@_ && ($_[0]||1) != ($self->{'first_row'}+1) ) { $self->{'first_row'} = shift; #SQL starts counting at 0 $self->{'first_row'}--; #gotta redo the search if changing pages $self->RedoSearch(); } return ( $self->{'first_row'} ); } =head2 _ItemsCounter Returns the current position in the record set. =cut sub _ItemsCounter { my $self = shift; return $self->{'itemscount'}; } =head2 Count Returns the number of records in the set. =cut sub Count { my $self = shift; # An unlimited search returns no tickets return 0 unless ($self->_isLimited); # If we haven't actually got all objects loaded in memory, we # really just want to do a quick count from the database. if ( $self->{'must_redo_search'} ) { # If we haven't already asked the database for the row count, do that $self->_DoCount unless ( $self->{'raw_rows'} ); #Report back the raw # of rows in the database return ( $self->{'raw_rows'} ); } # If we have loaded everything from the DB we have an # accurate count already. else { return $self->_RecordCount; } } =head2 CountAll Returns the total number of potential records in the set, ignoring any L settings. =cut # 22:24 [Robrt(500@outer.space)] It has to do with Caching. # 22:25 [Robrt(500@outer.space)] The documentation says it ignores the limit. # 22:25 [Robrt(500@outer.space)] But I don't believe thats true. # 22:26 [msg(Robrt)] yeah. I # 22:26 [msg(Robrt)] yeah. I'm not convinced it does anything useful right now # 22:26 [msg(Robrt)] especially since until a week ago, it was setting one variable and returning another # 22:27 [Robrt(500@outer.space)] I remember. # 22:27 [Robrt(500@outer.space)] It had to do with which Cached value was returned. # 22:27 [msg(Robrt)] (given that every time we try to explain it, we get it Wrong) # 22:27 [Robrt(500@outer.space)] Because Count can return a different number than actual NumberOfResults # 22:28 [msg(Robrt)] in what case? # 22:28 [Robrt(500@outer.space)] CountAll _always_ used the return value of _DoCount(), as opposed to Count which would return the cached number of # results returned. # 22:28 [Robrt(500@outer.space)] IIRC, if you do a search with a Limit, then raw_rows will == Limit. # 22:31 [msg(Robrt)] ah. # 22:31 [msg(Robrt)] that actually makes sense # 22:31 [Robrt(500@outer.space)] You should paste this conversation into the CountAll docs. # 22:31 [msg(Robrt)] perhaps I'll create a new method that _actually_ do that. # 22:32 [msg(Robrt)] since I'm not convinced it's been doing that correctly sub CountAll { my $self = shift; # An unlimited search returns no tickets return 0 unless ($self->_isLimited); # If we haven't actually got all objects loaded in memory, we # really just want to do a quick count from the database. # or if we have paging enabled then we count as well and store it in count_all if ( $self->{'must_redo_search'} || ( $self->RowsPerPage && !$self->{'count_all'} ) ) { # If we haven't already asked the database for the row count, do that $self->_DoCount(1); #Report back the raw # of rows in the database return ( $self->{'count_all'} ); } # if we have paging enabled and have count_all then return it elsif ( $self->RowsPerPage ) { return ( $self->{'count_all'} ); } # If we have loaded everything from the DB we have an # accurate count already. else { return $self->_RecordCount; } } =head2 IsLast Returns true if the current row is the last record in the set. =cut sub IsLast { my $self = shift; return undef unless $self->Count; if ( $self->_ItemsCounter == $self->Count ) { return (1); } else { return (0); } } =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. =item ALIAS Alias of a table the field is in; defaults to C
=item FUNCTION A SQL function that should be selected instead of FIELD or applied to it. =item AS The B alias to use instead of the default. The default column alias is either the column's name (i.e. what is passed to FIELD) if it is in this table (ALIAS is 'main') or an autogenerated alias. Pass C to skip column aliasing entirely. =back C, C and C are combined according to L. 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; 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 method to retrieve the column's result: my $time_alias = $articles->Column(FUNCTION => 'NOW()'); my $article = $articles->First; my $now = $article->_Value( $time_alias ); To choose the column's alias yourself, pass a value for the AS parameter (see above). Be careful not to conflict with existing column aliases. =cut sub Column { my $self = shift; my %args = ( TABLE => undef, ALIAS => undef, FIELD => undef, FUNCTION => undef, @_); $args{'ALIAS'} ||= 'main'; my $name = $self->CombineFunctionWithField( %args ) || 'NULL'; my $column = $args{'AS'}; if (not defined $column and not exists $args{'AS'}) { 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} ||= [] }, defined($column) ? "$name AS \L$column" : $name; return $column; } =head2 CombineFunctionWithField Takes a hash with three optional arguments: FUNCTION, FIELD and ALIAS. Returns SQL with all three arguments combined according to the following rules. =over 4 =item * FUNCTION or undef returned when FIELD is not provided =item * 'main' ALIAS is used if not provided =item * ALIAS.FIELD returned when FUNCTION is not provided =item * NULL returned if FUNCTION is 'NULL' =item * If FUNCTION contains '?' (question marks) then they are replaced with ALIAS.FIELD and result returned. =item * If FUNCTION has no '(' (opening parenthesis) then ALIAS.FIELD is appended in parentheses and returned. =back Examples: $obj->CombineFunctionWithField() => undef $obj->CombineFunctionWithField(FUNCTION => 'FOO') => 'FOO' $obj->CombineFunctionWithField(FIELD => 'foo') => 'main.foo' $obj->CombineFunctionWithField(ALIAS => 'bar', FIELD => 'foo') => 'bar.foo' $obj->CombineFunctionWithField(FUNCTION => 'FOO(?, ?)', FIELD => 'bar') => 'FOO(main.bar, main.bar)' $obj->CombineFunctionWithField(FUNCTION => 'FOO', ALIAS => 'bar', FIELD => 'baz') => 'FOO(bar.baz)' $obj->CombineFunctionWithField(FUNCTION => 'NULL', FIELD => 'bar') => 'NULL' =cut sub CombineFunctionWithField { my $self = shift; my %args = ( FUNCTION => undef, ALIAS => undef, FIELD => undef, @_ ); unless ( $args{'FIELD'} ) { return $args{'FUNCTION'} || undef; } my $field = ($args{'ALIAS'} || 'main') .'.'. $args{'FIELD'}; return $field unless $args{'FUNCTION'}; my $func = $args{'FUNCTION'}; if ( $func =~ /^DISTINCT\s*COUNT$/i ) { $func = "COUNT(DISTINCT $field)"; } # If we want to substitute elsif ( $func =~ s/\?/$field/g ) { # no need to do anything, we already replaced } # If we want to call a simple function on the column elsif ( $func !~ /\(/ && lc($func) ne 'null' ) { $func = "\U$func\E($field)"; } return $func; } =head2 Columns LIST Specify that we want to load only the columns in LIST =cut sub Columns { my $self = shift; $self->Column( FIELD => $_ ) for @_; } =head2 AdditionalColumn Calls L, but first ensures that this table's standard columns are selected as well. Thus, each call to this method results in an additional column selected instead of replacing the default columns. Takes a hash of parameters which is the same as L. Returns the result of calling L. =cut sub AdditionalColumn { my $self = shift; $self->Column( FUNCTION => "main.*", AS => undef ) unless grep { /^\Qmain.*\E$/ } @{$self->{columns}}; return $self->Column(@_); } =head2 Fields TABLE Return a list of fields in TABLE. These fields are in the case presented by the database, which may be case-sensitive. =cut sub Fields { return (shift)->_Handle->Fields( @_ ); } =head2 HasField { TABLE => undef, FIELD => undef } Returns true if TABLE has field FIELD. Return false otherwise Note: Both TABLE and FIELD are case-sensitive (See: L) =cut sub HasField { my $self = shift; my %args = ( FIELD => undef, TABLE => undef, @_); my $table = $args{TABLE} or die; my $field = $args{FIELD} or die; return grep { $_ eq $field } $self->Fields($table); } =head2 Table [TABLE] If called with an argument, sets this collection's table. Always returns this collection's table. =cut sub Table { my $self = shift; $self->{table} = shift if (@_); return $self->{table}; } =head2 QueryHint [Hint] If called with an argument, sets a query hint for this collection. Always returns the query hint. When the query hint is included in the SQL query, the C will be included for you. Here's an example query hint for Oracle: $sb->QueryHint("+CURSOR_SHARING_EXACT"); =cut sub QueryHint { my $self = shift; $self->{query_hint} = shift if (@_); return $self->{query_hint}; } =head2 QueryHintFormatted Returns the query hint formatted appropriately for inclusion in SQL queries. =cut sub QueryHintFormatted { my $self = shift; my $QueryHint = $self->QueryHint; return $QueryHint ? " /* $QueryHint */ " : " "; } =head1 DEPRECATED METHODS =head2 GroupBy DEPRECATED. Alias for the L method. =cut sub GroupBy { (shift)->GroupByCols( @_ ) } =head2 SetTable DEPRECATED. Alias for the L method. =cut sub SetTable { my $self = shift; return $self->Table(@_); } =head2 ShowRestrictions DEPRECATED AND DOES NOTHING. =cut sub ShowRestrictions { } =head2 ImportRestrictions DEPRECATED AND DOES NOTHING. =cut sub ImportRestrictions { } # not even documented sub DEBUG { warn "DEBUG is deprecated" } if( eval { require capitalization } ) { capitalization->unimport( __PACKAGE__ ); } 1; __END__ =head1 TESTING In order to test most of the features of C, you need to provide C with a test database. For each DBI driver that you would like to test, set the environment variables C, C, and C to a database name, database username, and database password, where "FOO" is the driver name in all uppercase. You can test as many drivers as you like. (The appropriate C module needs to be installed in order for the test to work.) Note that the C driver will automatically be tested if C is installed, using a temporary file as the database. For example: SB_TEST_MYSQL=test SB_TEST_MYSQL_USER=root SB_TEST_MYSQL_PASS=foo \ SB_TEST_PG=test SB_TEST_PG_USER=postgres make test =head1 AUTHOR Best Practical Solutions, LLC Emodules@bestpractical.comE =head1 BUGS All bugs should be reported via email to L or via the web at L. =head1 LICENSE AND COPYRIGHT Copyright (C) 2001-2014, Best Practical Solutions LLC. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO DBIx::SearchBuilder::Handle, DBIx::SearchBuilder::Record. =cut DBIx-SearchBuilder-1.67/.gitignore0000644000175000017500000000013012740776544016637 0ustar vagrantvagrantMakefile Makefile.bak Makefile.old MANIFEST.old MANIFEST.bak pm_to_blib blib/ MYMETA.* DBIx-SearchBuilder-1.67/t/0000755000175000017500000000000012743225026015103 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/t/01searches.t0000644000175000017500000005123412740776544017250 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 150; 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"); my $count_all = init_data( 'TestApp::User', $handle ); ok( $count_all, "init users data" ); my $users_obj = TestApp::Users->new( $handle ); isa_ok( $users_obj, 'DBIx::SearchBuilder' ); is( $users_obj->_Handle, $handle, "same handle as we used in constructor"); # check that new object returns 0 records in any case is( $users_obj->_RecordCount, 0, '_RecordCount returns 0 on not limited obj' ); is( $users_obj->Count, 0, 'Count returns 0 on not limited obj' ); is( $users_obj->IsLast, undef, 'IsLast returns undef on not limited obj after Count' ); is( $users_obj->First, undef, 'First returns undef on not limited obj' ); is( $users_obj->IsLast, undef, 'IsLast returns undef on not limited obj after First' ); is( $users_obj->Last, undef, 'Last returns undef on not limited obj' ); is( $users_obj->IsLast, undef, 'IsLast returns undef on not limited obj after Last' ); $users_obj->GotoFirstItem; is( $users_obj->Next, undef, 'Next returns undef on not limited obj' ); is( $users_obj->IsLast, undef, 'IsLast returns undef on not limited obj after Next' ); # XXX TODO FIXME: may be this methods should be implemented # $users_obj->GotoLastItem; # is( $users_obj->Prev, undef, 'Prev returns undef on not limited obj' ); my $items_ref = $users_obj->ItemsArrayRef; isa_ok( $items_ref, 'ARRAY', 'ItemsArrayRef always returns array reference' ); is_deeply( $items_ref, [], 'ItemsArrayRef returns [] on not limited obj' ); # unlimit new object and check $users_obj->UnLimit; is( $users_obj->Count, $count_all, 'Count returns same number of records as was inserted' ); isa_ok( $users_obj->First, 'DBIx::SearchBuilder::Record', 'First returns record object' ); isa_ok( $users_obj->Last, 'DBIx::SearchBuilder::Record', 'Last returns record object' ); $users_obj->GotoFirstItem; isa_ok( $users_obj->Next, 'DBIx::SearchBuilder::Record', 'Next returns record object' ); $items_ref = $users_obj->ItemsArrayRef; isa_ok( $items_ref, 'ARRAY', 'ItemsArrayRef always returns array reference' ); is( scalar @{$items_ref}, $count_all, 'ItemsArrayRef returns same number of records as was inserted' ); $users_obj->RedoSearch; $items_ref = $users_obj->ItemsArrayRef; isa_ok( $items_ref, 'ARRAY', 'ItemsArrayRef always returns array reference' ); is( scalar @{$items_ref}, $count_all, 'ItemsArrayRef returns same number of records as was inserted' ); # try to use $users_obj for all tests, after each call to CleanSlate it should look like new obj. # and test $obj->new syntax my $clean_obj = $users_obj->new( $handle ); isa_ok( $clean_obj, 'DBIx::SearchBuilder' ); # basic limits $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Login', VALUE => 'obra' ); is( $users_obj->Count, 1, 'found one user with login obra' ); TODO: { local $TODO = 'require discussion'; is( $users_obj->IsLast, undef, 'IsLast returns undef before we fetch any record' ); } my $first_rec = $users_obj->First; isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' ); is( $users_obj->IsLast, 1, '1 record in the collection then first rec is last'); is( $first_rec->Login, 'obra', 'login is correct' ); my $last_rec = $users_obj->Last; is( $last_rec, $first_rec, 'Last returns same object as First' ); is( $users_obj->IsLast, 1, 'IsLast always returns 1 after Last call'); $users_obj->GotoFirstItem; my $next_rec = $users_obj->Next; is( $next_rec, $first_rec, 'Next returns same object as First' ); is( $users_obj->IsLast, 1, 'IsLast returns 1 after fetch first record with Next method'); is( $users_obj->Next, undef, 'only one record in the collection' ); TODO: { local $TODO = 'require discussion'; is( $users_obj->IsLast, undef, 'Next returns undef, IsLast returns undef too'); } $items_ref = $users_obj->ItemsArrayRef; isa_ok( $items_ref, 'ARRAY', 'ItemsArrayRef always returns array reference' ); is( scalar @{$items_ref}, 1, 'ItemsArrayRef has only 1 record' ); # similar basic limit, but with different OPERATORS and less First/Next/Last tests # LIKE $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Name', OPERATOR => 'LIKE', VALUE => 'Glass' ); is( $users_obj->Count, 1, "found one user with 'Glass' in the name" ); $first_rec = $users_obj->First; isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' ); is( $first_rec->Login, 'glasser', 'login is correct' ); # MATCHES $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Name', OPERATOR => 'MATCHES', VALUE => 'lass' ); is( $users_obj->Count, 0, "found no user matching 'lass' in the name" ); $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Name', OPERATOR => 'MATCHES', VALUE => '%lass' ); is( $users_obj->Count, 0, "found no user matching '%lass' in the name" ); $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Name', OPERATOR => 'MATCHES', VALUE => 'lass%' ); is( $users_obj->Count, 0, "found no user matching 'lass%' in the name" ); $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Name', OPERATOR => 'MATCHES', VALUE => '%lass%' ); is( $users_obj->Count, 1, "found one user matching '%lass%' in the name" ); $first_rec = $users_obj->First; isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' ); is( $first_rec->Login, 'glasser', 'login is correct' ); # STARTSWITH $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Name', OPERATOR => 'STARTSWITH', VALUE => 'Ruslan' ); is( $users_obj->Count, 1, "found one user who name starts with 'Ruslan'" ); $first_rec = $users_obj->First; isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' ); is( $first_rec->Login, 'cubic', 'login is correct' ); # ENDSWITH $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Name', OPERATOR => 'ENDSWITH', VALUE => 'Tang' ); is( $users_obj->Count, 1, "found one user who name ends with 'Tang'" ); $first_rec = $users_obj->First; isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' ); is( $first_rec->Login, 'autrijus', 'login is correct' ); # IS NULL # XXX TODO FIXME: FIELD => undef should be handled as NULL $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'IS', VALUE => 'NULL' ); is( $users_obj->Count, 2, "found 2 users who has unknown phone number" ); # IS NOT NULL $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'IS NOT', VALUE => 'NULL', QOUTEVALUE => 0 ); is( $users_obj->Count, $count_all - 2, "found users who has phone number filled" ); # IN [...] operator $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => ['obra', 'cubic'] ); is( $users_obj->Count, 2, "found two users using IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'cubic', 'obra' ], 'found correct records', ); $users_obj->CleanSlate; $users_obj->Limit( FIELD => 'Login', OPERATOR => 'NOT IN', VALUE => ['obra', 'cubic'] ); is( $users_obj->Count, 2, "found two users using NOT IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'autrijus', 'glasser' ], 'found correct records', ); # IN $collection operator $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); { my $tmp = $users_obj->Clone; $tmp->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => ['obra', 'cubic'] ); $users_obj->Limit( FIELD => 'id', OPERATOR => 'IN', VALUE => $tmp ); } is( $users_obj->Count, 2, "found two users using IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'cubic', 'obra' ], 'found correct records', ); $users_obj->CleanSlate; { my $tmp = $users_obj->Clone; $tmp->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => ['obra', 'cubic'] ); $users_obj->Limit( FIELD => 'id', OPERATOR => 'NOT IN', VALUE => $tmp ); } is( $users_obj->Count, 2, "found two users using IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'autrijus', 'glasser' ], 'found correct records', ); # IN with object and Column preselected $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); { my $tmp = $users_obj->Clone; $tmp->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => ['obra', 'cubic'] ); $tmp->Column(FIELD => 'Login'); $users_obj->Limit( FIELD => 'Login', OPERATOR => 'IN', VALUE => $tmp ); } is( $users_obj->Count, 2, "found two users using IN operator" ); is_deeply( [ sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [ 'cubic', 'obra' ], 'found correct records', ); # ORDER BY / GROUP BY $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->UnLimit; $users_obj->GroupByCols({FIELD => 'Login'}); $users_obj->OrderBy(FIELD => 'Login', ORDER => 'desc'); $users_obj->Column(FIELD => 'Login'); is( $users_obj->Count, $count_all, "group by / order by finds right amount"); $first_rec = $users_obj->First; isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' ); is( $first_rec->Login, 'obra', 'login is correct' ); $users_obj->CleanSlate; TODO: { local $TODO = 'we leave order_by after clean slate, fixing this results in many RT failures'; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); } { $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->GroupBy({FUNCTION => 'Login'}); $users_obj->OrderBy(FIELD => 'Login', ORDER => 'desc'); $users_obj->Column(FIELD => 'Login'); is( $users_obj->Count, $count_all, "group by / order by finds right amount"); $first_rec = $users_obj->First; isa_ok( $first_rec, 'DBIx::SearchBuilder::Record', 'First returns record object' ); is( $first_rec->Login, 'obra', 'login is correct' ); } { $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->GroupBy({FUNCTION => 'SUBSTR(Login, 1, 1)', }); $users_obj->Column(FIELD => 'Login', FUNCTION => 'SUBSTR(Login, 1, 1)'); my @list = sort map $_->Login, @{ $users_obj->ItemsArrayRef }; is_deeply( \@list, [qw(a c g o)], 'correct values' ); } { $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->GroupBy({FUNCTION => 'SUBSTR(?, 1, 1)', FIELD => 'Login'}); $users_obj->Column(FIELD => 'Login', FUNCTION => 'SUBSTR(?, 1, 1)'); my @list = sort map $_->Login, @{ $users_obj->ItemsArrayRef }; is_deeply( \@list, [qw(a c g o)], 'correct values' ); } $users_obj = TestApp::Users->new( $handle ); # Let's play a little with ENTRYAGGREGATOR # EA defaults to OR for the same field $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'IS', VALUE => 'NULL', QOUTEVALUE => 0 ); $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'LIKE', VALUE => 'X' ); is( $users_obj->Count, 4, "found users who has no phone or it has X char" ); # set AND for the same field $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Login', OPERATOR => 'NOT LIKE', VALUE => 'c' ); $users_obj->Limit( ENTRYAGGREGATOR => 'AND', FIELD => 'Login', OPERATOR => 'LIKE', VALUE => 'u' ); is( $users_obj->Count, 1, "found users who has no phone or it has X char" ); # default is AND for different fields $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->Limit( FIELD => 'Phone', OPERATOR => 'IS', VALUE => 'NULL', QOUTEVALUE => 0 ); $users_obj->Limit( FIELD => 'Login', OPERATOR => 'LIKE', VALUE => 'r' ); is( $users_obj->Count, 2, "found users who has no phone number or login has 'r' char" ); # Let's play with RowsPerPage # RowsPerPage(0) # https://rt.cpan.org/Ticket/Display.html?id=42988 $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->UnLimit; $users_obj->RowsPerPage(0); is( $users_obj->Count, $count_all, "found all users" ); ok( $users_obj->First, "fetched first user" ); # walk all pages $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); $users_obj->UnLimit; $users_obj->OrderBy(FIELD => 'Login'); $users_obj->RowsPerPage(2); { my %seen; my $saw_on_page = 0; my $pages = 0; my $prev_login = ''; do { $saw_on_page = 0; while ( my $user = $users_obj->Next ) { $saw_on_page++; $seen{ $user->id }++; ok( $prev_login lt $user->Login, "order is correct" ); } last unless $saw_on_page; $pages++; if ( $pages * 2 <= $count_all ) { is( $saw_on_page, 2, "saw only two on the page" ); } else { is( $saw_on_page, $count_all - ($pages * 2), "saw slightly less users on the last page"); } $users_obj->NextPage; } while ( $saw_on_page ); ok( !grep( $_ != 1, values %seen ), "saw each user only once") or do { use Data::Dumper; diag Dumper(\%seen) }; is( scalar keys %seen, $count_all, "saw all users" ) } # two steps forward, on step back $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->OrderBy(FIELD => 'Login'); $users_obj->RowsPerPage(1); for ( 1 .. $count_all-1) { my $u = $users_obj->Next; ok( $u, "got a user"); ok(!$users_obj->Next, "only on the page"); $users_obj->NextPage; isnt( $users_obj->Next->id, $u->id, "got a user and he is different"); ok(!$users_obj->Next, "only on the page"); $users_obj->PrevPage; is( $users_obj->Next->id, $u->id, "got a user and he is the same"); ok(!$users_obj->Next, "only on the page"); $users_obj->NextPage; } # tricky variant: skip 1, but show 2 $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->OrderBy(FIELD => 'Login'); $users_obj->RowsPerPage(2); $users_obj->FirstRow(2); { my $u = $users_obj->Next; is( $u->Login, 'cubic', "cubic is second in the list"); } { my $u = $users_obj->Next; 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" ); } $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( $users_obj->Column(FIELD => 'id'), "id" ); is( my $id_alias = $users_obj->Column(FIELD => 'id', AS => 'foo'), "foo" ); my $u = $users_obj->Next; is( $u->_Value($id_alias), $u->id, "fetched id with custom alias" ); } $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( $users_obj->Column(FUNCTION => "main.*", AS => undef), undef ); my $u = $users_obj->Next; ok $u->{fetched}{"\L$_"}, "fetched field $_" for keys %{$u->_ClassAccessible}; } $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; { is( my $id_alias = $users_obj->AdditionalColumn(FIELD => 'id', AS => 'foo'), "foo" ); my $u = $users_obj->Next; is( $u->_Value($id_alias), $u->id, "fetched id with custom alias" ); ok $u->{fetched}{"\L$_"}, "fetched normal field $_" for keys %{$u->_ClassAccessible}; } # Last without running the search first $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; $users_obj->OrderBy( FIELD => "Login", ORDER => "ASC" ); is $users_obj->Last->Login, "obra", "Found last record correctly before search was run"; cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql {[ "DROP TABLE IF EXISTS Users", <Table('Users'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Login => {read => 1, write => 1, type => 'varchar(18)' }, Name => {read => 1, write => 1, type => 'varchar(36)' }, Phone => {read => 1, write => 1, type => 'varchar(18)', default => ''}, } } sub init_data { return ( [ 'Login', 'Name', 'Phone' ], [ 'cubic', 'Ruslan U. Zakirov', '+7-903-264-XX-XX' ], [ 'obra', 'Jesse Vincent', undef ], [ 'glasser', 'David Glasser', undef ], [ 'autrijus', 'Autrijus Tang', '+X-XXX-XXX-XX-XX' ], ); } 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; DBIx-SearchBuilder-1.67/t/10schema.t0000644000175000017500000000553112740776544016712 0ustar vagrantvagrant#!/usr/bin/perl use strict; use warnings; use Test::More; use constant TESTS_PER_DRIVER => 14; our @AvailableDrivers; BEGIN { require("t/utils.pl"); my $total = 3 + scalar(@AvailableDrivers) * TESTS_PER_DRIVER; if( not eval { require DBIx::DBSchema } ) { plan skip_all => "DBIx::DBSchema not installed"; } else { plan tests => $total; } } BEGIN { use_ok("DBIx::SearchBuilder::SchemaGenerator"); use_ok("DBIx::SearchBuilder::Handle"); } require_ok("t/testmodels.pl"); foreach my $d ( @AvailableDrivers ) { SKIP: { unless ($d eq 'Pg') { skip "first goal is to work on Pg", 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, "DBIx::SearchBuilder::Handle::$d"); isa_ok($handle->dbh, 'DBI::db'); my $SG = DBIx::SearchBuilder::SchemaGenerator->new($handle); isa_ok($SG, 'DBIx::SearchBuilder::SchemaGenerator'); isa_ok($SG->_db_schema, 'DBIx::DBSchema'); is($SG->CreateTableSQLText, '', "no tables means no sql"); my $ret = $SG->AddModel('Sample::This::Does::Not::Exist'); ok($ret == 0, "couldn't add model from nonexistent class"); like($ret->error_message, qr/Error making new object from Sample::This::Does::Not::Exist/, "couldn't add model from nonexistent class"); is($SG->CreateTableSQLText, '', "no tables means no sql"); $ret = $SG->AddModel('Sample::Address'); ok($ret != 0, "added model from real class"); is_ignoring_space($SG->CreateTableSQLText, <new; isa_ok($employee, 'Sample::Employee'); $ret = $SG->AddModel($employee); ok($ret != 0, "added model from an instantiated object"); is_ignoring_space($SG->CreateTableSQLText, <CreateTableSQLStatements; is_ignoring_space($SG->CreateTableSQLText, $manually_make_text, 'CreateTableSQLText is the statements in CreateTableSQLStatements') }} sub is_ignoring_space { my $a = shift; my $b = shift; $a =~ s/^\s+//; $a =~ s/\s+$//; $a =~ s/\s+/ /g; $b =~ s/^\s+//; $b =~ s/\s+$//; $b =~ s/\s+/ /g; unshift @_, $b; unshift @_, $a; goto &is; } DBIx-SearchBuilder-1.67/t/02distinct_values.t0000644000175000017500000000745312740776544020660 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 9; 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; } diag "testing $d" if $ENV{TEST_VERBOSE}; my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); my $ret = init_schema( 'TestApp', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back"); my $count_all = init_data( 'TestApp::User', $handle ); ok( $count_all, "init users data" ); my $users_obj = TestApp::Users->new( $handle ); isa_ok( $users_obj, 'DBIx::SearchBuilder' ); is( $users_obj->_Handle, $handle, "same handle as we used in constructor"); # unlimit new object and check $users_obj->UnLimit; { 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( [$users_obj->DistinctFieldValues('GroupName', Order => 'ASC')], [qw(dev sales)], 'Correct list' ); is_deeply( [$users_obj->DistinctFieldValues('GroupName', Order => 'DESC')], [reverse qw(dev sales)], 'Correct list' ); cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql { <Table('Users'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Login => {read => 1, write => 1, type => 'varchar(18)' }, GroupName => {read => 1, write => 1, type => 'varchar(36)' }, } } sub init_data { return ( [ 'Login', 'GroupName' ], [ 'cubic', 'dev' ], [ 'obra', 'boss' ], [ 'kevin', 'dev' ], [ 'keri', 'sales' ], [ 'some', undef ], ); } 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; DBIx-SearchBuilder-1.67/t/01records.t0000644000175000017500000002202412740776544017107 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 66; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { unless( has_schema( 'TestApp::Address', $d ) ) { skip "No schema for '$d' driver", TESTS_PER_DRIVER; } unless( should_test( $d ) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); my $ret = init_schema( 'TestApp::Address', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back"); my $rec = TestApp::Address->new($handle); isa_ok($rec, 'DBIx::SearchBuilder::Record'); # Handle->Fields is_deeply( [$handle->Fields('Address')], [qw(id name phone employeeid)], "listed all columns in the table" ); is_deeply( [$handle->Fields('Some')], [], "no table -> no fields" ); # _Accessible testings is( $rec->_Accessible('id' => 'read'), 1, 'id is accessible for read' ); is( $rec->_Accessible('id' => 'write'), undef, 'id is not accessible for write' ); is( $rec->_Accessible('id'), undef, "any field is not accessible in undefined mode" ); is( $rec->_Accessible('unexpected_field' => 'read'), undef, "field doesn't exist and can't be accessible for read" ); is_deeply( [sort($rec->ReadableAttributes)], [qw(EmployeeId Name Phone id)], 'readable attributes' ); is_deeply( [sort($rec->WritableAttributes)], [qw(EmployeeId Name Phone)], 'writable attributes' ); can_ok($rec,'Create'); my ($id) = $rec->Create( Name => 'Jesse', Phone => '617 124 567'); ok($id,"Created record ". $id); ok($rec->Load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); is ($rec->Name, 'Jesse', "The record's name is Jesse"); my ($val, $msg) = $rec->SetName('Obra'); ok($val, $msg) ; is($rec->Name, 'Obra', "We did actually change the name"); # Validate immutability of the field id ($val, $msg) = $rec->Setid( $rec->id + 1 ); ok(!$val, $msg); is($msg, 'Immutable field', 'id is immutable field'); is($rec->id, $id, "The record still has its id"); # Check some non existant field ok( !eval{ $rec->SomeUnexpectedField }, "The record has no 'SomeUnexpectedField'"); { # test produce DBI warning local $SIG{__WARN__} = sub {return}; is( $rec->_Value( 'SomeUnexpectedField' ), undef, "The record has no 'SomeUnexpectedField'"); } ($val, $msg) = $rec->SetSomeUnexpectedField( 'foo' ); ok(!$val, $msg); is($msg, 'Nonexistant field?', "Field doesn't exist"); ($val, $msg) = $rec->_Set('SomeUnexpectedField', 'foo'); ok(!$val, "$msg"); # Validate truncation on update ($val,$msg) = $rec->SetName('1234567890123456789012345678901234567890'); ok($val, $msg); is($rec->Name, '12345678901234', "Truncated on update"); $val = $rec->TruncateValue(Phone => '12345678901234567890'); is($val, '123456789012345678', 'truncate by length attribute'); # Test unicode truncation: my $univalue = "這是個測試"; ($val,$msg) = $rec->SetName($univalue.$univalue); ok($val, $msg) ; is($rec->Name, '這是個測'); # make sure we do _not_ truncate things which should not be truncated ($val,$msg) = $rec->SetEmployeeId('1234567890'); ok($val, $msg) ; is($rec->EmployeeId, '1234567890', "Did not truncate id on create"); # make sure we do truncation on create my $newrec = TestApp::Address->new($handle); my $newid = $newrec->Create( Name => '1234567890123456789012345678901234567890', EmployeeId => '1234567890' ); $newrec->Load($newid); ok ($newid, "Created a new record"); is($newrec->Name, '12345678901234', "Truncated on create"); is($newrec->EmployeeId, '1234567890', "Did not truncate id on create"); # no prefetch feature and _LoadFromSQL sub checks $newrec = TestApp::Address->new($handle); ($val, $msg) = $newrec->_LoadFromSQL('SELECT id FROM Address WHERE id = ?', $newid); is($val, 1, 'found object'); is($newrec->Name, '12345678901234', "autoloaded not prefetched field"); is($newrec->EmployeeId, '1234567890', "autoloaded not prefetched field"); # _LoadFromSQL and missing PK $newrec = TestApp::Address->new($handle); ($val, $msg) = $newrec->_LoadFromSQL('SELECT Name FROM Address WHERE Name = ?', '12345678901234'); is($val, 0, "didn't find object"); is($msg, "Missing a primary key?", "reason is missing PK"); # _LoadFromSQL and not existant row $newrec = TestApp::Address->new($handle); ($val, $msg) = $newrec->_LoadFromSQL('SELECT id FROM Address WHERE id = ?', 0); is($val, 0, "didn't find object"); is($msg, "Couldn't find row", "reason is wrong id"); # _LoadFromSQL and wrong SQL $newrec = TestApp::Address->new($handle); { local $SIG{__WARN__} = sub{return}; ($val, $msg) = $newrec->_LoadFromSQL('SELECT ...'); } is($val, 0, "didn't find object"); like($msg, qr/^Couldn't execute query/, "reason is bad SQL"); # test Load* methods $newrec = TestApp::Address->new($handle); $newrec->Load(); is( $newrec->id, undef, "can't load record with undef id"); $newrec = TestApp::Address->new($handle); $newrec->LoadByCol( Name => '12345678901234' ); is( $newrec->id, $newid, "load record by 'Name' column value"); # LoadByCol with operator $newrec = TestApp::Address->new($handle); $newrec->LoadByCol( Name => { value => '%45678%', operator => 'LIKE' } ); is( $newrec->id, $newid, "load record by 'Name' with LIKE"); # LoadByPrimaryKeys $newrec = TestApp::Address->new($handle); ($val, $msg) = $newrec->LoadByPrimaryKeys( id => $newid ); ok( $val, "load record by PK"); is( $newrec->id, $newid, "loaded correct record"); $newrec = TestApp::Address->new($handle); ($val, $msg) = $newrec->LoadByPrimaryKeys( {id => $newid} ); ok( $val, "load record by PK"); is( $newrec->id, $newid, "loaded correct record" ); $newrec = TestApp::Address->new($handle); ($val, $msg) = $newrec->LoadByPrimaryKeys( Phone => 'some' ); ok( !$val, "couldn't load, missing PK field"); is( $msg, "Missing PK field: 'id'", "right error message" ); # LoadByCols and empty or NULL values $rec = TestApp::Address->new($handle); $id = $rec->Create( Name => 'Obra', Phone => undef ); ok( $id, "new record"); $rec = TestApp::Address->new($handle); $rec->LoadByCols( Name => 'Obra', Phone => undef, EmployeeId => '' ); is( $rec->id, $id, "loaded record by empty value" ); # __Set error paths $rec = TestApp::Address->new($handle); $rec->Load( $id ); $val = $rec->SetName( 'Obra' ); isa_ok( $val, 'Class::ReturnValue', "couldn't set same value, error returned"); is( ($val->as_array)[1], "That is already the current value", "correct error message" ); is( $rec->Name, 'Obra', "old value is still there"); $val = $rec->SetName( 'invalid' ); isa_ok( $val, 'Class::ReturnValue', "couldn't set invalid value, error returned"); is( ($val->as_array)[1], 'Illegal value for Name', "correct error message" ); is( $rec->Name, 'Obra', "old value is still there"); ( $val, $msg ) = $rec->SetName(); ok( $val, $msg ); is( $rec->Name, undef, "no value means null"); # deletes $newrec = TestApp::Address->new($handle); $newrec->Load( $newid ); is( $newrec->Delete, 1, 'successfuly delete record'); $newrec = TestApp::Address->new($handle); $newrec->Load( $newid ); is( $newrec->id, undef, "record doesn't exist any more"); cleanup_schema( 'TestApp::Address', $handle ); }} # SKIP, foreach blocks 1; package TestApp::Address; 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('Address'); $self->_Handle($handle); } sub ValidateName { my ($self, $value) = @_; return 1 unless defined $value; return 0 if $value =~ /invalid/i; return 1; } sub _ClassAccessible { { id => {read => 1, type => 'int(11)', default => ''}, Name => {read => 1, write => 1, type => 'varchar(14)', default => ''}, Phone => {read => 1, write => 1, type => 'varchar(18)', length => 18, default => ''}, EmployeeId => {read => 1, write => 1, type => 'int(8)', default => ''}, } } sub schema_mysql { < 63; 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', "Got handle for $d"); my $ret = init_schema( 'TestApp', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back"); my $emp = TestApp::Employee->new($handle); my $e_id = $emp->Create( Name => 'RUZ' ); ok($e_id, "Got an id for the new employee: $e_id"); $emp->Load($e_id); is($emp->id, $e_id); my $phone_collection = $emp->Phones; isa_ok($phone_collection, 'TestApp::PhoneCollection'); { my $ph = $phone_collection->Next; is($ph, undef, "No phones yet"); } my $phone = TestApp::Phone->new($handle); isa_ok( $phone, 'TestApp::Phone'); my $p_id = $phone->Create( Employee => $e_id, Phone => '+7(903)264-03-51'); is($p_id, 1, "Loaded phone $p_id"); $phone->Load( $p_id ); my $obj = $phone->Employee; ok($obj, "Employee #$e_id has phone #$p_id"); isa_ok( $obj, 'TestApp::Employee'); is($obj->id, $e_id); is($obj->Name, 'RUZ'); { $phone_collection->RedoSearch; my $ph = $phone_collection->Next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p_id, 'found first phone'); is($ph->Phone, '+7(903)264-03-51'); is($phone_collection->Next, undef); } # tests for no object mapping my $val = $phone->Phone; is( $val, '+7(903)264-03-51', 'Non-object things still work'); my $emp2 = TestApp::Employee->new($handle); isa_ok($emp2, 'TestApp::Employee'); my $e2_id = $emp2->Create( Name => 'Dave' ); ok($e2_id, "Got an id for the new employee: $e2_id"); $emp2->Load($e2_id); is($emp2->id, $e2_id); my $phone2_collection = $emp2->Phones; isa_ok($phone2_collection, 'TestApp::PhoneCollection'); { my $ph = $phone2_collection->Next; is($ph, undef, "new emp has no phones"); } { $phone_collection->RedoSearch; my $ph = $phone_collection->Next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p_id, 'first emp still has phone'); is($ph->Phone, '+7(903)264-03-51'); is($phone_collection->Next, undef); } $phone->SetEmployee($e2_id); my $emp3 = $phone->Employee; isa_ok($emp3, 'TestApp::Employee'); is($emp3->Name, 'Dave', 'changed employees by ID'); is($emp3->id, $emp2->id); { $phone_collection->RedoSearch; is($phone_collection->Next, undef, "first emp lost phone"); } { $phone2_collection->RedoSearch; my $ph = $phone2_collection->Next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p_id, 'new emp stole the phone'); is($ph->Phone, '+7(903)264-03-51'); is($phone2_collection->Next, undef); } $phone->SetEmployee($emp); my $emp4 = $phone->Employee; isa_ok($emp4, 'TestApp::Employee'); is($emp4->Name, 'RUZ', 'changed employees by obj'); is($emp4->id, $emp->id); { $phone2_collection->RedoSearch; is($phone2_collection->Next, undef, "second emp lost phone"); } { $phone_collection->RedoSearch; my $ph = $phone_collection->Next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p_id, 'first emp stole the phone'); is($ph->Phone, '+7(903)264-03-51'); is($phone_collection->Next, undef); } my $phone2 = TestApp::Phone->new($handle); isa_ok( $phone2, 'TestApp::Phone'); my $p2_id = $phone2->Create( Employee => $e_id, Phone => '123456'); ok($p2_id, "Loaded phone $p2_id"); $phone2->Load( $p2_id ); { $phone_collection->RedoSearch; my $ph = $phone_collection->Next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p_id, 'still has this phone'); is($ph->Phone, '+7(903)264-03-51'); $ph = $phone_collection->Next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p2_id, 'now has that phone'); is($ph->Phone, '123456'); is($phone_collection->Next, undef); } # Test Create with obj as argument my $phone3 = TestApp::Phone->new($handle); isa_ok( $phone3, 'TestApp::Phone'); my $p3_id = $phone3->Create( Employee => $emp, Phone => '7890'); ok($p3_id, "Loaded phone $p3_id"); $phone3->Load( $p3_id ); { $phone_collection->RedoSearch; my $ph = $phone_collection->Next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p_id, 'still has this phone'); is($ph->Phone, '+7(903)264-03-51'); $ph = $phone_collection->Next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p2_id, 'still has that phone'); is($ph->Phone, '123456'); $ph = $phone_collection->Next; isa_ok($ph, 'TestApp::Phone'); is($ph->id, $p3_id, 'even has this other phone'); is($ph->Phone, '7890'); is($phone_collection->Next, undef); } cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE TABLE Employees ( id integer primary key, Name varchar(36) ) }, q{ CREATE TABLE Phones ( id integer primary key, Employee integer NOT NULL, Phone varchar(18) ) } ] } sub schema_mysql { [ q{ CREATE TEMPORARY TABLE Employees ( id integer AUTO_INCREMENT primary key, Name varchar(36) ) }, q{ CREATE TEMPORARY TABLE Phones ( id integer AUTO_INCREMENT primary key, Employee integer NOT NULL, Phone varchar(18) ) } ] } sub schema_pg { [ q{ CREATE TEMPORARY TABLE Employees ( id serial PRIMARY KEY, Name varchar ) }, q{ CREATE TEMPORARY TABLE Phones ( id serial PRIMARY KEY, Employee integer references Employees(id), Phone varchar ) } ] } package TestApp::Employee; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub Table { 'Employees' } sub Schema { return { Name => { TYPE => 'varchar' }, Phones => { REFERENCES => 'TestApp::PhoneCollection', KEY => 'Employee' } }; } sub _Value { my $self = shift; my $x = ($self->__Value(@_)); return $x; } 1; package TestApp::Phone; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub Table { 'Phones' } sub Schema { return { Employee => { REFERENCES => 'TestApp::Employee' }, Phone => { TYPE => 'varchar' }, } } package TestApp::PhoneCollection; use base qw/DBIx::SearchBuilder/; sub Table { my $self = shift; my $tab = $self->NewItem->Table(); return $tab; } sub NewItem { my $self = shift; my $class = 'TestApp::Phone'; return $class->new( $self->_Handle ); } 1; DBIx-SearchBuilder-1.67/t/03cud_from_select.t0000644000175000017500000001773312740776544020620 0ustar vagrantvagrant#!/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 = ? AND GroupId = ?', 1, 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'; DBIx-SearchBuilder-1.67/t/02searches_joins.t0000644000175000017500000003423212740776544020452 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 59; 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"); my $count_users = init_data( 'TestApp::User', $handle ); ok( $count_users, "init users data" ); my $count_groups = init_data( 'TestApp::Group', $handle ); ok( $count_groups, "init groups data" ); my $count_us2gs = init_data( 'TestApp::UsersToGroup', $handle ); ok( $count_us2gs, "init users&groups relations data" ); my $clean_obj = TestApp::Users->new( $handle ); my $users_obj = $clean_obj->Clone; is_deeply( $users_obj, $clean_obj, 'after Clone looks the same'); diag "inner JOIN with ->Join method" if $ENV{'TEST_VERBOSE'}; { ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); ok( $alias, "Join returns alias" ); TODO: { local $TODO = "is joined doesn't mean is limited, count returns 0"; is( $users_obj->Count, 3, "three users are members of the groups" ); } # fake limit to check if join actually joins $users_obj->Limit( FIELD => 'id', OPERATOR => 'IS NOT', VALUE => 'NULL' ); is( $users_obj->Count, 3, "three users are members of the groups" ); } diag "LEFT JOIN with ->Join method" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); ok( $alias, "Join returns alias" ); $users_obj->Limit( ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS', VALUE => 'NULL' ); ok( $users_obj->BuildSelectQuery =~ /LEFT JOIN/, 'LJ is not optimized away'); is( $users_obj->Count, 1, "user is not member of any group" ); is( $users_obj->First->id, 3, "correct user id" ); } diag "LEFT JOIN with IS NOT NULL on the right side" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); ok( $alias, "Join returns alias" ); $users_obj->Limit( ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS NOT', VALUE => 'NULL' ); ok( $users_obj->BuildSelectQuery !~ /LEFT JOIN/, 'LJ is optimized away'); is( $users_obj->Count, 3, "users whos is memebers of at least one group" ); } diag "LEFT JOIN with ->Join method and using alias" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->NewAlias( 'UsersToGroups' ); ok( $alias, "new alias" ); is($users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', ALIAS2 => $alias, FIELD2 => 'UserId' ), $alias, "joined table" ); $users_obj->Limit( ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS', VALUE => 'NULL' ); ok( $users_obj->BuildSelectQuery =~ /LEFT JOIN/, 'LJ is not optimized away'); is( $users_obj->Count, 1, "user is not member of any group" ); } diag "main <- alias <- join" if $ENV{'TEST_VERBOSE'}; { # The join depends on the alias, we should build joins with correct order. $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->NewAlias( 'UsersToGroups' ); ok( $alias, "new alias" ); ok( $users_obj->_isJoined, "object with aliases is joined"); $users_obj->Limit( FIELD => 'id', VALUE => "$alias.UserId", QUOTEVALUE => 0); ok( my $groups_alias = $users_obj->Join( ALIAS1 => $alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id', ), "joined table" ); $users_obj->Limit( ALIAS => $groups_alias, FIELD => 'Name', VALUE => 'Developers' ); is( $users_obj->Count, 3, "three members" ); } diag "main <- alias <- join into main" if $ENV{'TEST_VERBOSE'}; { # DBs' parsers don't like: FROM X, Y JOIN C ON C.f = X.f $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); ok( my $groups_alias = $users_obj->NewAlias( 'Groups' ), "new alias" ); ok( my $g2u_alias = $users_obj->Join( ALIAS1 => 'main', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId', ), "joined table" ); $users_obj->Limit( ALIAS => $g2u_alias, FIELD => 'GroupId', VALUE => "$groups_alias.id", QUOTEVALUE => 0); $users_obj->Limit( ALIAS => $groups_alias, FIELD => 'Name', VALUE => 'Developers' ); #diag $users_obj->BuildSelectQuery; is( $users_obj->Count, 3, "three members" ); } diag "cascaded LEFT JOIN optimization" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); ok( $alias, "Join returns alias" ); $alias = $users_obj->Join( TYPE => 'LEFT', ALIAS1 => $alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id' ); $users_obj->Limit( ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS NOT', VALUE => 'NULL' ); ok( $users_obj->BuildSelectQuery !~ /LEFT JOIN/, 'both LJs are optimized away'); is( $users_obj->Count, 3, "users whos is memebers of at least one group" ); } diag "LEFT JOIN optimization and OR clause" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); $users_obj->_OpenParen('my_clause'); $users_obj->Limit( SUBCLAUSE => 'my_clause', ALIAS => $alias, FIELD => 'id', OPERATOR => 'IS NOT', VALUE => 'NULL' ); $users_obj->Limit( SUBCLAUSE => 'my_clause', ENTRY_AGGREGATOR => 'OR', FIELD => 'id', VALUE => 3 ); $users_obj->_CloseParen('my_clause'); ok( $users_obj->BuildSelectQuery =~ /LEFT JOIN/, 'LJ is not optimized away'); is( $users_obj->Count, 4, "all users" ); } diag "DISTINCT in Join" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId', DISTINCT => 1, ); $users_obj->Limit( ALIAS => $alias, FIELD => 'GroupId', VALUE => 1, ); ok( $users_obj->BuildSelectQuery !~ /DISTINCT|GROUP\s+BY/i, 'no distinct in SQL'); is_deeply( [ sort map $_->Login, @{$users_obj->ItemsArrayRef} ], [ 'aurelia', 'ivan', 'john' ], "members of dev group" ); } diag "DISTINCT in NewAlias" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $alias = $users_obj->NewAlias('UsersToGroups', DISTINCT => 1); $users_obj->Join( FIELD1 => 'id', ALIAS2 => $alias, FIELD2 => 'UserId', ); $users_obj->Limit( ALIAS => $alias, FIELD => 'GroupId', VALUE => 1, ); ok( $users_obj->BuildSelectQuery !~ /DISTINCT|GROUP\s+BY/i, 'no distinct in SQL'); is_deeply( [ sort map $_->Login, @{$users_obj->ItemsArrayRef} ], [ 'aurelia', 'ivan', 'john' ], "members of dev group" ); } diag "mixing DISTINCT" if $ENV{'TEST_VERBOSE'}; { $users_obj->CleanSlate; is_deeply( $users_obj, $clean_obj, 'after CleanSlate looks like new object'); ok( !$users_obj->_isJoined, "new object isn't joined"); my $u2g_alias = $users_obj->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId', DISTINCT => 0, ); my $g_alias = $users_obj->Join( ALIAS1 => $u2g_alias, FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id', DISTINCT => 1, ); $users_obj->Limit( ALIAS => $g_alias, FIELD => 'Name', VALUE => 'Developers', ); $users_obj->Limit( ALIAS => $g_alias, FIELD => 'Name', VALUE => 'Sales', ); ok( $users_obj->BuildSelectQuery =~ /DISTINCT|GROUP\s+BY/i, 'distinct in SQL'); is_deeply( [ sort map $_->Login, @{$users_obj->ItemsArrayRef} ], [ 'aurelia', 'ivan', 'john' ], "members of dev group" ); } 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) ) }, ] } sub schema_mysql { [ q{ CREATE TEMPORARY TABLE Users ( id integer primary key AUTO_INCREMENT, Login varchar(36) ) }, q{ CREATE TEMPORARY 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 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::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)'}, Login => {read => 1, write => 1, type => 'varchar(36)'}, } } sub init_data { return ( [ 'Login' ], [ 'ivan' ], [ 'john' ], [ 'bob' ], [ 'aurelia' ], ); } package TestApp::Users; 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; package TestApp::Group; 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('Groups'); $self->_Handle($handle); } 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::Groups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); $self->Table('Groups'); } sub NewItem { return TestApp::Group->new( (shift)->_Handle ) } 1; package TestApp::UsersToGroup; 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('UsersToGroups'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, UserId => {read => 1, type => 'int(11)'}, GroupId => {read => 1, type => 'int(11)'}, } } sub init_data { return ( [ 'GroupId', 'UserId' ], # dev group [ 1, 1 ], [ 1, 2 ], [ 1, 4 ], # sales # [ 2, 0 ], # support [ 3, 1 ], ); } package TestApp::UsersToGroups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->Table('UsersToGroups'); return $self->SUPER::_Init( Handle => shift ); } sub NewItem { return TestApp::UsersToGroup->new( (shift)->_Handle ) } 1; DBIx-SearchBuilder-1.67/t/03compatibility.t0000644000175000017500000000137212740776544020324 0ustar vagrantvagrant#!/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; DBIx-SearchBuilder-1.67/t/02records_integers.t0000644000175000017500000001246712740776544021022 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 37; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { unless( has_schema( 'TestApp::Address', $d ) ) { skip "No schema for '$d' driver", TESTS_PER_DRIVER; } unless( should_test( $d ) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); my $ret = init_schema( 'TestApp::Address', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back"); { my $rec = TestApp::Address->new($handle); isa_ok($rec, 'DBIx::SearchBuilder::Record'); my $id = $rec->Create; ok($id, 'created record'); $rec->Load( $id ); is($rec->id, $id, 'loaded record'); is($rec->Optional, undef, 'correct value'); is($rec->Mandatory, 1, 'correct value'); } { my $rec = TestApp::Address->new($handle); isa_ok($rec, 'DBIx::SearchBuilder::Record'); my $id = $rec->Create( Mandatory => undef ); ok($id, 'created record'); $rec->Load( $id ); is($rec->id, $id, 'loaded record'); is($rec->Optional, undef, 'correct value'); is($rec->Mandatory, 1, 'correct value, we have default'); } { my $rec = TestApp::Address->new($handle); isa_ok($rec, 'DBIx::SearchBuilder::Record'); # Pg doesn't like "int_column = ''" syntax my $id = $rec->Create( Optional => '' ); ok($id, 'created record'); $rec->Load( $id ); is($rec->id, $id, 'loaded record'); is($rec->Optional, 0, 'correct value, fallback to 0 for empty string'); is($rec->Mandatory, 1, 'correct value, we have default'); # set operations on optional field my $status = $rec->SetOptional( 1 ); ok($status, "status ok") or diag $status->error_message; is($rec->Optional, 1, 'set optional field to 1'); $status = $rec->SetOptional( undef ); ok($status, "status ok") or diag $status->error_message; is($rec->Optional, undef, 'undef equal to NULL'); { my $warn; local $SIG{__WARN__} = sub { $warn++; warn @_; }; $status = $rec->SetOptional(''); ok( $status, "status ok" ) or diag $status->error_message; is( $rec->Optional, 0, 'empty string should be threated as zero' ); ok( !$warn, 'no warning to set value from null to not-null' ); } $status = $rec->SetOptional; ok($status, "status ok") or diag $status->error_message; is($rec->Optional, undef, 'no value is NULL too'); $status = $rec->SetOptional; ok(!$status, 'same null value set'); is( ( $status->as_array )[1], "That is already the current value", "correct error message" ); is($rec->Optional, undef, 'no value is NULL too'); # set operations on mandatory field $status = $rec->SetMandatory( 2 ); ok($status, "status ok") or diag $status->error_message; is($rec->Mandatory, 2, 'set optional field to 2'); $status = $rec->SetMandatory( undef ); ok($status, "status ok") or diag $status->error_message; is($rec->Mandatory, 1, 'fallback to default'); $status = $rec->SetMandatory( '' ); ok($status, "status ok") or diag $status->error_message; is($rec->Mandatory, 0, 'empty string should be threated as zero'); $status = $rec->SetMandatory; ok($status, "status ok") or diag $status->error_message; is($rec->Mandatory, 1, 'no value on set also fallback'); } cleanup_schema( 'TestApp::Address', $handle ); }} # SKIP, foreach blocks package TestApp::Address; 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('MyTable'); $self->_Handle($handle); } sub _ClassAccessible { { id => { read => 1, type => 'int(11)' }, Optional => { read => 1, write => 1, type => 'int(11)' }, Mandatory => { read => 1, write => 1, type => 'int(11)', default => 1, no_nulls => 1 }, } } sub schema_mysql { < 'Devel::Symdump is not installed'; } elsif( not eval { require capitalization } ) { plan skip_all => 'capitalization pragma is not installed'; } else { plan tests => scalar @MODULES; } foreach my $mod( @MODULES ) { eval "require $mod"; my $dump = Devel::Symdump->new($mod); my @methods = (); foreach my $method (map { s/^\Q$mod\E:://; $_ } $dump->functions) { push @methods, $method; my $nocap = nocap( $method ); push @methods, $nocap if $nocap ne $method; } can_ok( $mod, @methods ); } sub nocap { my $method = shift; return $method if grep( { $_ eq $method } @SPEC_METHODS ); $method =~ s/(?<=[a-z])([A-Z]+)/"_" . lc($1)/eg; return lc($method); } DBIx-SearchBuilder-1.67/t/20set_edge_cases.t0000644000175000017500000000715712740776544020416 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 20; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d (@AvailableDrivers) { SKIP: { unless ( has_schema( 'TestApp::Address', $d ) ) { skip "No schema for '$d' driver", TESTS_PER_DRIVER; } unless ( should_test($d) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } my $handle = get_handle($d); connect_handle($handle); isa_ok( $handle->dbh, 'DBI::db' ); my $ret = init_schema( 'TestApp::Address', $handle ); isa_ok( $ret, 'DBI::st', "Inserted the schema. got a statement handle back" ); my $rec = TestApp::Address->new($handle); my ($id) = $rec->Create( Name => 'foo', Counter => 3 ); ok( $id, "Created record " . $id ); ok( $rec->Load($id), "Loaded the record" ); is( $rec->Name, 'foo', "name is foo" ); is( $rec->Counter, 3, "number is 3" ); my ( $val, $msg ) = $rec->SetName('bar'); ok( $val, $msg ); is( $rec->Name, 'bar', "name is changed to bar" ); ( $val, $msg ) = $rec->SetName(undef); ok( !$val, $msg ); like( $msg, qr/Illegal value for non-nullable field Name/, 'error message' ); is( $rec->Name, 'bar', 'name is still bar' ); SKIP: { skip 'Oracle treats the empty string as a NULL' => 2 if $d eq 'Oracle'; ( $val, $msg ) = $rec->SetName(''); ok( $val, $msg ); is( $rec->Name, '', "name is changed to ''" ); } ( $val, $msg ) = $rec->SetCounter(42); ok( $val, $msg ); is( $rec->Counter, 42, 'number is changed to 42' ); ( $val, $msg ) = $rec->SetCounter(undef); ok( !$val, $msg ); like( $msg, qr/Illegal value for non-nullable field Counter/, 'error message' ); is( $rec->Counter, 42, 'number is still 42' ); ( $val, $msg ) = $rec->SetCounter(''); ok( $val, $msg ); is( $rec->Counter, 0, 'empty string implies 0 for integer field' ); cleanup_schema( 'TestApp::Address', $handle ); } } 1; package TestApp::Address; 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('Address'); $self->_Handle($handle); } sub _ClassAccessible { { id => { read => 1, type => 'int(11)', }, Name => { read => 1, write => 1, type => 'varchar(14)', no_nulls => 1 }, Counter => { read => 1, write => 1, type => 'int(8)', no_nulls => 1 }, }; } sub schema_mysql { < 38; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; my $handle; my $skip_tz_tests; 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' ); $skip_tz_tests = 0; if ( $d eq 'SQLite' ) { my $check = '2013-04-01 16:00:00'; my ($got) = $handle->dbh->selectrow_array("SELECT datetime(?,'localtime')", undef, $check); $skip_tz_tests = 1 if $got eq $check; } elsif ($d eq 'mysql') { my $check = '2013-04-01 16:00:00'; my ($got) = $handle->dbh->selectrow_array( "SELECT CONVERT_TZ(?, ?, ?)", undef, $check, 'UTC', 'Europe/Moscow' ); $skip_tz_tests = 1 if !$got || $got eq $check; } 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; SKIP: { skip "skipping timezone tests", 1 if $props->{'Timezone'} && $skip_tz_tests; 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 { <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; DBIx-SearchBuilder-1.67/t/02records_cachable.t0000644000175000017500000000654712740776544020726 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 16; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { unless( has_schema( 'TestApp::Address', $d ) ) { skip "No schema for '$d' driver", TESTS_PER_DRIVER; } unless( should_test( $d ) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); my $ret = init_schema( 'TestApp::Address', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back"); my $rec = TestApp::Address->new($handle); isa_ok($rec, 'DBIx::SearchBuilder::Record'); my ($id) = $rec->Create( Name => 'Jesse', Phone => '617 124 567'); ok($id,"Created record #$id"); ok($rec->Load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); is($rec->Name, 'Jesse', "The record's name is Jesse"); my $rec_cache = TestApp::Address->new($handle); my ($status, $msg) = $rec_cache->LoadById($id); ok($status, 'loaded record'); is($rec_cache->id, $id, 'the same record as we created'); is($msg, 'Fetched from cache', 'we fetched record from cache'); DBIx::SearchBuilder::Record::Cachable->FlushCache; ok($rec->LoadByCols( Name => 'Jesse' ), "Loaded the record"); is($rec->id, $id, "The record has its id"); is($rec->Name, 'Jesse', "The record's name is Jesse"); $rec_cache = TestApp::Address->new($handle); ($status, $msg) = $rec_cache->LoadById($id); ok($status, 'loaded record'); is($rec_cache->id, $id, 'the same record as we created'); is($msg, 'Fetched from cache', 'we fetched record from cache'); cleanup_schema( 'TestApp::Address', $handle ); }} # SKIP, foreach blocks 1; package TestApp::Address; use base qw/DBIx::SearchBuilder::Record::Cachable/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Address'); $self->_Handle($handle); } sub _ClassAccessible { return { id => {read => 1, type => 'int(11)', default => ''}, Name => {read => 1, write => 1, type => 'varchar(14)', default => ''}, Phone => {read => 1, write => 1, type => 'varchar(18)', length => 18, default => ''}, EmployeeId => {read => 1, write => 1, type => 'int(8)', default => ''}, } } sub _CacheConfig { return { 'cache_for_sec' => 60, }; } sub schema_mysql { < 17; 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" ); my $users = TestApp::Users->new( $handle ); $users->UnLimit; $users->Column( FIELD => 'Result' ); my $column = $users->Column( FUNCTION => $users->_Handle->DateTimeIntervalFunction( From => 'Created', To => 'Resolved' ), ); while ( my $user = $users->Next ) { is $user->__Value( $column ), $user->Result; } $users = TestApp::Users->new( $handle ); $users->UnLimit; $users->Column( FIELD => 'Result' ); $column = $users->Column( FUNCTION => $users->_Handle->DateTimeIntervalFunction( From => { FIELD => 'Created' }, To => { FIELD => 'Resolved' }, ), ); while ( my $user = $users->Next ) { is $user->__Value( $column ), $user->Result; } cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql { <Table('Users'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Created => {read => 1, write => 1, type => 'datetime' }, Resolved => {read => 1, write => 1, type => 'datetime' }, Result => {read => 1, type => 'int(11)' }, } } sub init_data { return ( [ 'Created', 'Resolved', 'Result' ], [ undef, undef , undef ], [ undef , '2011-05-20 19:53:23', undef ], [ '2011-05-20 19:53:23', undef , undef ], [ '2011-05-20 19:53:23', '2011-05-20 19:53:23', 0], [ '2011-05-20 19:53:23', '2011-05-21 20:54:24', 1*24*60*60+1*60*60+1*60+1], [ '2011-05-20 19:53:23', '2011-05-19 18:52:22', -(1*24*60*60+1*60*60+1*60+1)], [ '2011-05-20 19:53:23', '2012-09-20 19:53:23', 42249600], ); } 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; DBIx-SearchBuilder-1.67/t/02searches_function.t0000644000175000017500000002027312740776544021155 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 18; 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"); my $count_users = init_data( 'TestApp::User', $handle ); ok( $count_users, "init users data" ); my $count_groups = init_data( 'TestApp::Group', $handle ); ok( $count_groups, "init groups data" ); my $count_us2gs = init_data( 'TestApp::UsersToGroup', $handle ); ok( $count_us2gs, "init users&groups relations data" ); my $clean_obj = TestApp::Users->new( $handle ); diag "FUNCTION with ? in Limit" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->Limit( FUNCTION => 'SUBSTR(?, 1, 1)', FIELD => 'Login', VALUE => 'I' ); is( $users_obj->Count, 1, "only one value" ); is( $users_obj->First->Login, 'Ivan', "ivan is the only match" ); } diag "make sure case insensitive works" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->Limit( FUNCTION => 'SUBSTR(?, 1, 1)', FIELD => 'Login', VALUE => 'i' ); is( $users_obj->Count, 1, "only one value" ); is( $users_obj->First->Login, 'Ivan', "ivan is the only match" ); } diag "FUNCTION without ?, but with () in Limit" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->Limit( FUNCTION => 'SUBSTR(main.Login, 1, 1)', FIELD => 'Login', VALUE => 'I' ); is( $users_obj->Count, 1, "only one value" ); is( $users_obj->First->Login, 'Ivan', "ivan is the only match" ); } diag "FUNCTION with ? in Column" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->UnLimit; $users_obj->Column(FIELD => 'id'); my $alias = $users_obj->Column(FIELD => 'Login', FUNCTION => 'SUBSTR(?, 1, 1)'); is( $alias, 'Login' ); is_deeply( [sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [sort qw(a B I j)], 'correct values', ); } diag "FUNCTION without ?, but with () in Column" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->UnLimit; $users_obj->Column(FIELD => 'id'); my $alias = $users_obj->Column(FIELD => 'Login', FUNCTION => 'SUBSTR(main.Login, 1, 1)'); is( $alias, 'Login' ); is_deeply( [sort map $_->Login, @{ $users_obj->ItemsArrayRef } ], [sort qw(a B I j)], 'correct values', ); } diag "NULL FUNCTION in Column" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->UnLimit; $users_obj->Column(FIELD => 'id'); $users_obj->Column(FIELD => 'Login', FUNCTION => 'NULL'); is_deeply( [ map $_->Login, @{ $users_obj->ItemsArrayRef } ], [(undef)x4], 'correct values', ); } diag "FUNCTION w/0 ? and () in Column" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->UnLimit; my $u2g_alias = $users_obj->Join( TYPE => 'LEFT', FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId', ); $users_obj->GroupBy({FIELD => 'Login'}); $users_obj->Column(FIELD => 'Login'); my $column_alias = $users_obj->Column(FIELD => 'id', ALIAS => $u2g_alias, FUNCTION => 'COUNT'); isnt( $column_alias, 'id' ); is_deeply( { map { $_->Login => $_->_Value($column_alias) } @{ $users_obj->ItemsArrayRef } }, { Ivan => 2, john => 1, Bob => 0, aurelia => 1 }, 'correct values', ); } 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) ) }, ] } sub schema_mysql { [ q{ CREATE TEMPORARY TABLE Users ( id integer primary key AUTO_INCREMENT, Login varchar(36) ) }, q{ CREATE TEMPORARY 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 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::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)'}, Login => {read => 1, write => 1, type => 'varchar(36)'}, } } sub init_data { return ( [ 'Login' ], [ 'Ivan' ], [ 'john' ], [ 'Bob' ], [ 'aurelia' ], ); } package TestApp::Users; 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; package TestApp::Group; 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('Groups'); $self->_Handle($handle); } 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::Groups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); $self->Table('Groups'); } sub NewItem { return TestApp::Group->new( (shift)->_Handle ) } 1; package TestApp::UsersToGroup; 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('UsersToGroups'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, UserId => {read => 1, type => 'int(11)'}, GroupId => {read => 1, type => 'int(11)'}, } } sub init_data { return ( [ 'GroupId', 'UserId' ], # dev group [ 1, 1 ], [ 1, 2 ], [ 1, 4 ], # sales # [ 2, 0 ], # support [ 3, 1 ], ); } package TestApp::UsersToGroups; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->Table('UsersToGroups'); return $self->SUPER::_Init( Handle => shift ); } sub NewItem { return TestApp::UsersToGroup->new( (shift)->_Handle ) } 1; DBIx-SearchBuilder-1.67/t/pod.t0000644000175000017500000000020112740776544016060 0ustar vagrantvagrantuse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); DBIx-SearchBuilder-1.67/t/03transactions.t0000644000175000017500000001512012740776544020157 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 52; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { unless( has_schema( 'TestApp::Address', $d ) ) { skip "No schema for '$d' driver", TESTS_PER_DRIVER; } unless( should_test( $d ) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } my $handle = get_handle( $d ); isa_ok($handle, 'DBIx::SearchBuilder::Handle'); { # clear PrevHandle no warnings 'once'; $DBIx::SearchBuilder::Handle::PrevHandle = undef; } diag("disconnected handle") if $ENV{'TEST_VERBOSE'}; is($handle->TransactionDepth, undef, "undefined transaction depth"); is($handle->BeginTransaction, undef, "couldn't begin transaction"); is($handle->TransactionDepth, undef, "still undefined transaction depth"); ok($handle->EndTransaction(Action => 'commit', Force => 1), "force commit success silently"); ok($handle->Commit('force'), "force commit success silently"); ok($handle->EndTransaction(Action => 'rollback', Force => 1), "force rollback success silently"); ok($handle->Rollback('force'), "force rollback success silently"); # XXX: ForceRollback function should deprecated ok($handle->ForceRollback, "force rollback success silently"); { my $warn = 0; local $SIG{__WARN__} = sub{ $_[0] =~ /transaction with none in progress/? $warn++: warn @_ }; ok(!$handle->Rollback, "not forced rollback returns false"); is($warn, 1, "not forced rollback fires warning"); ok(!$handle->Commit, "not forced commit returns false"); is($warn, 2, "not forced commit fires warning"); } connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); diag("connected handle without transaction") if $ENV{'TEST_VERBOSE'}; is($handle->TransactionDepth, 0, "transaction depth is 0"); ok($handle->Commit('force'), "force commit success silently"); ok($handle->Rollback('force'), "force rollback success silently"); { my $warn = 0; local $SIG{__WARN__} = sub{ $_[0] =~ /transaction with none in progress/? $warn++: warn @_ }; ok(!$handle->Rollback, "not forced rollback returns false"); is($warn, 1, "not forced rollback fires warning"); ok(!$handle->Commit, "not forced commit returns false"); is($warn, 2, "not forced commit fires warning"); } diag("begin and commit empty transaction") if $ENV{'TEST_VERBOSE'}; ok($handle->BeginTransaction, "begin transaction"); is($handle->TransactionDepth, 1, "transaction depth is 1"); ok($handle->Commit, "commit successed"); is($handle->TransactionDepth, 0, "transaction depth is 0"); diag("begin and rollback empty transaction") if $ENV{'TEST_VERBOSE'}; ok($handle->BeginTransaction, "begin transaction"); is($handle->TransactionDepth, 1, "transaction depth is 1"); ok($handle->Rollback, "rollback successed"); is($handle->TransactionDepth, 0, "transaction depth is 0"); diag("nested empty transactions") if $ENV{'TEST_VERBOSE'}; ok($handle->BeginTransaction, "begin transaction"); is($handle->TransactionDepth, 1, "transaction depth is 1"); ok($handle->BeginTransaction, "begin nested transaction"); is($handle->TransactionDepth, 2, "transaction depth is 2"); ok($handle->Commit, "commit successed"); is($handle->TransactionDepth, 1, "transaction depth is 1"); ok($handle->Commit, "commit successed"); is($handle->TransactionDepth, 0, "transaction depth is 0"); diag("init schema in transaction and commit") if $ENV{'TEST_VERBOSE'}; # MySQL doesn't support transactions for CREATE TABLE # so it's fake transactions test ok($handle->BeginTransaction, "begin transaction"); is($handle->TransactionDepth, 1, "transaction depth is 1"); my $ret = init_schema( 'TestApp::Address', $handle ); isa_ok($ret, 'DBI::st', "Inserted the schema. got a statement handle back"); ok($handle->Commit, "commit successed"); is($handle->TransactionDepth, 0, "transaction depth is 0"); diag("nested txns with mixed escaping actions") if $ENV{'TEST_VERBOSE'}; ok($handle->BeginTransaction, "begin transaction"); ok($handle->BeginTransaction, "begin nested transaction"); ok($handle->Rollback, "rollback successed"); { my $warn = 0; local $SIG{__WARN__} = sub{ $_[0] =~ /Rollback and commit are mixed/? $warn++: warn @_ }; ok($handle->Commit, "commit successed"); is($warn, 1, "not forced rollback fires warning"); } ok($handle->BeginTransaction, "begin transaction"); ok($handle->BeginTransaction, "begin nested transaction"); ok($handle->Commit, "rollback successed"); { my $warn = 0; local $SIG{__WARN__} = sub{ $_[0] =~ /Rollback and commit are mixed/? $warn++: warn @_ }; ok($handle->Rollback, "commit successed"); is($warn, 1, "not forced rollback fires warning"); } cleanup_schema( 'TestApp::Address', $handle ); }} # SKIP, foreach blocks 1; package TestApp::Address; use base qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Address'); $self->_Handle($handle); } sub ValidateName { my ($self, $value) = @_; return 0 if $value =~ /invalid/i; return 1; } sub _ClassAccessible { { id => {read => 1, type => 'int(11)', default => ''}, Name => {read => 1, write => 1, type => 'varchar(14)', default => ''}, Phone => {read => 1, write => 1, type => 'varchar(18)', length => 18, default => ''}, EmployeeId => {read => 1, write => 1, type => 'int(8)', default => ''}, } } sub schema_mysql { < 11; 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 ); unless ( $handle->HasSupportForNullsOrder ) { skip "Feature is not supported by $d", TESTS_PER_DRIVER; } isa_ok($handle->dbh, 'DBI::db'); my $ret = init_schema( 'TestApp', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back"); my $count_all = init_data( 'TestApp::User', $handle ); ok( $count_all, "init users data" ); my $users_obj = TestApp::Users->new( $handle ); $users_obj->UnLimit; # NULLs are small $handle->NullsOrder('small'); $users_obj->OrderBy(FIELD => 'Value', ORDER => 'ASC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ undef, 0, 1 ], ; $users_obj->OrderBy(FIELD => 'Value', ORDER => 'DESC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ 1, 0, undef ], ; # NULLs are large $handle->NullsOrder('large'); $users_obj->OrderBy(FIELD => 'Value', ORDER => 'ASC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ 0, 1, undef ], ; $users_obj->OrderBy(FIELD => 'Value', ORDER => 'DESC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ undef, 1, 0, ], ; # NULLs are first $handle->NullsOrder('first'); $users_obj->OrderBy(FIELD => 'Value', ORDER => 'ASC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ undef, 0, 1 ], ; $users_obj->OrderBy(FIELD => 'Value', ORDER => 'DESC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ undef, 1, 0, ], ; # NULLs are last $handle->NullsOrder('last'); $users_obj->OrderBy(FIELD => 'Value', ORDER => 'ASC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ 0, 1, undef ], ; $users_obj->OrderBy(FIELD => 'Value', ORDER => 'DESC' ); is_deeply [ map $_->Value, @{ $users_obj->ItemsArrayRef } ], [ 1, 0, undef ], ; cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql {[ "DROP TABLE IF EXISTS Users", <Table('Users'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Value => {read => 1, write => 1, type => 'int(11)' }, } } sub init_data { return ( [ 'Value', ], [ undef, ], [ 0, ], [ 1, ], ); } 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; DBIx-SearchBuilder-1.67/t/03rebless.t0000644000175000017500000000137312740776544017113 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; use DBIx::SearchBuilder::Handle; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 4; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { unless( should_test( $d ) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } my $handle = DBIx::SearchBuilder::Handle->new; ok($handle, "Made a generic handle"); is(ref $handle, 'DBIx::SearchBuilder::Handle', "It's really generic"); connect_handle_with_driver( $handle, $d ); isa_ok($handle->dbh, 'DBI::db'); isa_ok($handle, "DBIx::SearchBuilder::Handle::$d", "Specialized Handle") }} # SKIP, foreach blocks 1; DBIx-SearchBuilder-1.67/t/00.load.t0000644000175000017500000000144112740776544016442 0ustar vagrantvagrantuse Test::More tests => 12; BEGIN { use_ok("DBIx::SearchBuilder"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::Informix"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::mysql"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::mysqlPP"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::ODBC"); } BEGIN { SKIP: { skip "DBD::Oracle is not installed", 1 unless eval { require DBD::Oracle }; use_ok("DBIx::SearchBuilder::Handle::Oracle"); } } BEGIN { use_ok("DBIx::SearchBuilder::Handle::Pg"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::Sybase"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::SQLite"); } BEGIN { use_ok("DBIx::SearchBuilder::Record"); } BEGIN { use_ok("DBIx::SearchBuilder::Record::Cachable"); } DBIx-SearchBuilder-1.67/t/utils.pl0000644000175000017500000001065112740776544016620 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use File::Temp qw/ tempdir /; use File::Spec; =head1 VARIABLES =head2 @SupportedDrivers Array of all supported DBD drivers. =cut our @SupportedDrivers = qw( Informix mysql mysqlPP ODBC Oracle Pg SQLite Sybase ); =head2 @AvailableDrivers Array that lists only drivers from supported list that user has installed. =cut our @AvailableDrivers = grep { eval "require DBD::". $_ } @SupportedDrivers; =head1 FUNCTIONS =head2 get_handle Returns new DB specific handle. Takes one argument DB C<$type>. Other arguments uses to construct handle. =cut sub get_handle { my $type = shift; my $class = 'DBIx::SearchBuilder::Handle::'. $type; eval "require $class"; die $@ if $@; my $handle; $handle = $class->new( @_ ); return $handle; } =head2 handle_to_driver Returns driver name which gets from C<$handle> object argument. =cut sub handle_to_driver { my $driver = ref($_[0]); $driver =~ s/^.*:://; return $driver; } =head2 connect_handle Connects C<$handle> object to DB. =cut sub connect_handle { my $call = "connect_". lc handle_to_driver( $_[0] ); return unless defined &$call; goto &$call; } =head2 connect_handle_with_driver($handle, $driver) Connects C<$handle> using driver C<$driver>; can use this to test the magic that turns a C into a C on C. =cut sub connect_handle_with_driver { my $call = "connect_". lc $_[1]; return unless defined &$call; @_ = $_[0]; goto &$call; } sub connect_sqlite { my $dir = tempdir(CLEANUP => 1); my $handle = shift; return $handle->Connect( Driver => 'SQLite', Database => File::Spec->catfile($dir => "db.sqlite") ); } sub connect_mysql { my $handle = shift; return $handle->Connect( Driver => 'mysql', Database => $ENV{'SB_TEST_MYSQL'}, User => $ENV{'SB_TEST_MYSQL_USER'} || 'root', Password => $ENV{'SB_TEST_MYSQL_PASS'} || '', ); } sub connect_pg { my $handle = shift; return $handle->Connect( Driver => 'Pg', Database => $ENV{'SB_TEST_PG'}, User => $ENV{'SB_TEST_PG_USER'} || 'postgres', Password => $ENV{'SB_TEST_PG_PASS'} || '', ); } sub connect_oracle { my $handle = shift; return $handle->Connect( Driver => 'Oracle', Database => $ENV{'SB_TEST_ORACLE'}, Host => $ENV{'SB_TEST_ORACLE_HOST'}, SID => $ENV{'SB_TEST_ORACLE_SID'}, User => $ENV{'SB_TEST_ORACLE_USER'} || 'test', Password => $ENV{'SB_TEST_ORACLE_PASS'} || 'test', ); } =head2 should_test Checks environment for C variables. Returns true if specified DB back-end should be tested. Takes one argument C<$driver> name. =cut sub should_test { my $driver = shift; return 1 if lc $driver eq 'sqlite'; my $env = 'SB_TEST_'. uc $driver; return $ENV{$env}; } =head2 had_schema Returns true if C<$class> has schema for C<$driver>. =cut sub has_schema { my ($class, $driver) = @_; my $method = 'schema_'. lc $driver; return UNIVERSAL::can( $class, $method ); } =head2 init_schema Takes C<$class> and C<$handle> and inits schema by calling C method of the C<$class>. Returns last C on success or last return value of the SimpleQuery method on error. =cut sub init_schema { my ($class, $handle) = @_; my $call = "schema_". lc handle_to_driver( $handle ); my $schema = $class->$call(); $schema = ref( $schema )? $schema : [$schema]; my $ret; foreach my $query( @$schema ) { $ret = $handle->SimpleQuery( $query ); return $ret unless UNIVERSAL::isa( $ret, 'DBI::st' ); } return $ret; } =head2 cleanup_schema Takes C<$class> and C<$handle> and cleanup schema by calling C method of the C<$class> if method exists. Always returns undef. =cut sub cleanup_schema { my ($class, $handle) = @_; my $call = "cleanup_schema_". lc handle_to_driver( $handle ); return unless UNIVERSAL::can( $class, $call ); my $schema = $class->$call(); $schema = ref( $schema )? $schema : [$schema]; foreach my $query( @$schema ) { eval { $handle->SimpleQuery( $query ) }; } } =head2 init_data =cut sub init_data { my ($class, $handle) = @_; my @data = $class->init_data(); my @columns = @{ shift @data }; my $count = 0; foreach my $values ( @data ) { my %args; for( my $i = 0; $i < @columns; $i++ ) { $args{ $columns[$i] } = $values->[$i]; } my $rec = $class->new( $handle ); my $id = $rec->Create( %args ); die "Couldn't create record" unless $id; $count++; } return $count; } 1; DBIx-SearchBuilder-1.67/t/03versions.t0000644000175000017500000000210412740776544017315 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; use DBIx::SearchBuilder::Handle; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 6; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; 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 ); ok($handle, "Made a handle"); isa_ok($handle, 'DBIx::SearchBuilder::Handle'); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); my $full_version = $handle->DatabaseVersion( Short => 0 ); diag("Full version is '$full_version'") if defined $full_version && $ENV{'TEST_VERBOSE'}; ok($full_version, "returns full version"); my $short_version = $handle->DatabaseVersion; diag("Short version is '$short_version'") if defined $short_version && $ENV{'TEST_VERBOSE'}; ok($short_version, "returns short version"); like($short_version, qr{^[-\w\.]+$}, "short version has only \\w.-"); }} # SKIP, foreach blocks 1; DBIx-SearchBuilder-1.67/t/02records_object.t0000644000175000017500000000741612740776544020446 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 11; 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"); my $emp = TestApp::Employee->new($handle); my $e_id = $emp->Create( Name => 'RUZ' ); ok($e_id, "Got an ide for the new emplyee"); my $phone = TestApp::Phone->new($handle); isa_ok( $phone, 'TestApp::Phone', "it's atestapp::phone"); my $p_id = $phone->Create( Employee => $e_id, Phone => '+7(903)264-03-51'); # XXX: test fails if next string is commented is($p_id, 1, "Loaded record $p_id"); $phone->Load( $p_id ); my $obj = $phone->EmployeeObj($handle); ok($obj, "Employee #$e_id has phone #$p_id"); isa_ok( $obj, 'TestApp::Employee'); is($obj->id, $e_id); is($obj->Name, 'RUZ'); # tests for no object mapping my ($state, $msg) = $phone->ValueObj($handle); ok(!$state, "State is false"); is( $msg, 'No object mapping for field', 'Error message is correct'); cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_sqlite { [ q{ CREATE TABLE Employees ( id integer primary key, Name varchar(36) ) }, q{ CREATE TABLE Phones ( id integer primary key, Employee integer NOT NULL, Phone varchar(18) ) } ] } sub schema_mysql { [ q{ CREATE TEMPORARY TABLE Employees ( id integer AUTO_INCREMENT primary key, Name varchar(36) ) }, q{ CREATE TEMPORARY TABLE Phones ( id integer AUTO_INCREMENT primary key, Employee integer NOT NULL, Phone varchar(18) ) } ] } sub schema_pg { [ q{ CREATE TEMPORARY TABLE Employees ( id serial PRIMARY KEY, Name varchar ) }, q{ CREATE TEMPORARY TABLE Phones ( id serial PRIMARY KEY, Employee integer references Employees(id), Phone varchar ) } ] } sub schema_oracle { [ "CREATE SEQUENCE Employees_seq", "CREATE TABLE Employees ( id integer CONSTRAINT Employees_Key PRIMARY KEY, Name varchar(36) )", "CREATE SEQUENCE Phones_seq", "CREATE TABLE Phones ( id integer CONSTRAINT Phones_Key PRIMARY KEY, Employee integer NOT NULL, Phone varchar(18) )", ] } sub cleanup_schema_oracle { [ "DROP SEQUENCE Employees_seq", "DROP TABLE Employees", "DROP SEQUENCE Phones_seq", "DROP TABLE Phones", ] } package TestApp::Employee; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; use vars qw/$VERSION/; $VERSION=0.01; sub _Init { my $self = shift; my $handle = shift; $self->Table('Employees'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, Name => {read => 1, write => 1, type => 'varchar(18)'}, } } 1; package TestApp::Phone; use vars qw/$VERSION/; $VERSION=0.01; 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('Phones'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)'}, Employee => {read => 1, write => 1, type => 'int(11)', object => 'TestApp::Employee' }, Value => {read => 1, write => 1, type => 'varchar(18)'}, } } 1; DBIx-SearchBuilder-1.67/t/02order_outer.t0000644000175000017500000001273512740776544020010 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 98; 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"); my $lowest = ($d ne 'Pg' && $d ne 'Oracle')? '-': 'z'; diag "generate data" if $ENV{TEST_VERBOSE}; { my @tags = qw(a b c d); foreach my $i ( 1..30 ) { my $number_of_tags = int(rand(4)); my @t; push @t, $tags[int rand scalar @tags] while $number_of_tags--; my %seen = (); @t = grep !$seen{$_}++, @t; my $obj = TestApp::Object->new($handle); my ($oid) = $obj->Create( Name => join(",", sort @t) || $lowest ); ok($oid,"Created record ". $oid); ok($obj->Load($oid), "Loaded the record"); my $tags_ok = 1; foreach my $t( @t ) { my $tag = TestApp::Tag->new($handle); my ($tid) = $tag->Create( Object => $oid, Name => $t ); $tags_ok = 0 unless $tid; } ok($tags_ok, "Added tags"); } } # ASC order foreach my $direction ( qw(ASC DESC) ) { my $objs = TestApp::Objects->new($handle); $objs->UnLimit; my $tags_alias = $objs->Join( TYPE => 'LEFT', ALIAS1 => 'main', FIELD1 => 'id', TABLE2 => 'Tags', FIELD2 => 'Object', ); ok($tags_alias, "joined tags table"); $objs->OrderBy( ALIAS => $tags_alias, FIELD => 'Name', ORDER => $direction ); ok($objs->First, 'ok, we have at least one result'); $objs->GotoFirstItem; my ($order_ok, $last) = (1, $direction eq 'ASC'? '-': 'zzzz'); while ( my $obj = $objs->Next ) { my $tmp; if ( $direction eq 'ASC' ) { $tmp = (substr($last, 0, 1) cmp substr($obj->Name, 0, 1)); } else { $tmp = -(substr($last, -1, 1) cmp substr($obj->Name, -1, 1)); } if ( $tmp > 0 ) { $order_ok = 0; last; } $last = $obj->Name; } ok($order_ok, "$direction order is correct") or do { diag "Wrong $direction query: ". $objs->BuildSelectQuery; $objs->GotoFirstItem; while ( my $obj = $objs->Next ) { diag($obj->id .":". $obj->Name); } } } cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach blocks 1; package TestApp; sub schema_mysql { [ "CREATE TEMPORARY TABLE Objects ( id integer AUTO_INCREMENT, Name varchar(36), PRIMARY KEY (id) )", "CREATE TEMPORARY TABLE Tags ( id integer AUTO_INCREMENT, Object integer NOT NULL, Name varchar(36), PRIMARY KEY (id) )", ] } sub schema_pg { [ "CREATE TEMPORARY TABLE Objects ( id serial PRIMARY KEY, Name varchar(36) )", "CREATE TEMPORARY TABLE Tags ( id serial PRIMARY KEY, Object integer NOT NULL, Name varchar(36) )", ]} sub schema_sqlite {[ "CREATE TABLE Objects ( id integer primary key, Name varchar(36) )", "CREATE TABLE Tags ( id integer primary key, Object integer NOT NULL, Name varchar(36) )", ]} sub schema_oracle { [ "CREATE SEQUENCE Objects_seq", "CREATE TABLE Objects ( id integer CONSTRAINT Objects_Key PRIMARY KEY, Name varchar(36) )", "CREATE SEQUENCE Tags_seq", "CREATE TABLE Tags ( id integer CONSTRAINT Tags_Key PRIMARY KEY, Object integer NOT NULL, Name varchar(36) )", ] } sub cleanup_schema_oracle { [ "DROP SEQUENCE Objects_seq", "DROP TABLE Objects", "DROP SEQUENCE Tags_seq", "DROP TABLE Tags", ] } 1; package TestApp::Object; 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('Objects'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Name => {read => 1, write => 1, type => 'varchar(36)' }, } } 1; package TestApp::Objects; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); $self->Table('Objects'); } sub NewItem { my $self = shift; return TestApp::Object->new( $self->_Handle ); } 1; package TestApp::Tag; 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('Tags'); $self->_Handle($handle); } sub _ClassAccessible { { id => {read => 1, type => 'int(11)' }, Object => {read => 1, type => 'int(11)' }, Name => {read => 1, write => 1, type => 'varchar(36)' }, } } 1; package TestApp::Tags; # use TestApp::User; use base qw/DBIx::SearchBuilder/; sub _Init { my $self = shift; $self->SUPER::_Init( Handle => shift ); $self->Table('Tags'); } sub NewItem { my $self = shift; return TestApp::Tag->new( $self->_Handle ); } 1; DBIx-SearchBuilder-1.67/t/testmodels.pl0000644000175000017500000000131412740776544017637 0ustar vagrantvagrantpackage Sample::Address; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; # Class and instance method sub Table { "Addresses" } # Class and instance method sub Schema { return { Name => { TYPE => 'varchar', DEFAULT => 'Frank', }, Phone => { TYPE => 'varchar', }, EmployeeId => { REFERENCES => 'Sample::Employee', }, } } package Sample::Employee; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub Table { "Employees" } sub Schema { return { Name => { TYPE => 'varchar', }, Dexterity => { TYPE => 'integer', }, } } 1;DBIx-SearchBuilder-1.67/t/01basics.t0000644000175000017500000000074612740776544016721 0ustar vagrantvagrant#!/usr/bin/perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 4; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { use_ok('DBIx::SearchBuilder::Handle::'. $d); my $handle = get_handle( $d ); isa_ok($handle, 'DBIx::SearchBuilder::Handle'); isa_ok($handle, 'DBIx::SearchBuilder::Handle::'. $d); can_ok($handle, 'dbh'); } } 1; DBIx-SearchBuilder-1.67/README0000644000175000017500000000257712740776544015550 0ustar vagrantvagrantNAME DBIx::SearchBuilder - Encapsulate SQL queries and rows in simple perl objects DESCRIPTION This module provides an object-oriented mechanism for retrieving and updating data in a DBI-accesible database. INSTALLATION $ perl Makefile.PL $ make $ make test # but see below for how to actually test against a test database # make install TESTING In order to test most of the features of "DBIx::SearchBuilder", you need to provide "make test" with a test database. For each DBI driver that you would like to test, set the environment variables "SB_TEST_FOO", "SB_TEST_FOO_USER", and "SB_TEST_FOO_PASS" to a database name, database username, and database password, where "FOO" is the driver name in all uppercase. You can test as many drivers as you like. (The appropriate "DBD::" module needs to be installed in order for the test to work.) Note that the "SQLite" driver will automatically be tested if "DBD::Sqlite" is installed, using a temporary file as the database. For example: SB_TEST_MYSQL=test SB_TEST_MYSQL_USER=root SB_TEST_MYSQL_PASS=foo \ SB_TEST_PG=test SB_TEST_PG_USER=postgres make test AUTHOR Copyright (c) 2001-2005 Jesse Vincent, jesse@fsck.com. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. DBIx-SearchBuilder-1.67/ex/0000755000175000017500000000000012743225026015254 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/ex/Example/0000755000175000017500000000000012743225026016647 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/ex/Example/Model/0000755000175000017500000000000012743225026017707 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/ex/Example/Model/Employee.pm0000644000175000017500000000033712740776544022044 0ustar vagrantvagrantpackage Example::Model::Employee; use base qw/DBIx::SearchBuilder::Record/; sub Table { "Employees" } sub Schema { return { Name => { TYPE => 'varchar', }, Dexterity => { TYPE => 'integer', }, } } 1;DBIx-SearchBuilder-1.67/ex/Example/Model/Address.pm0000644000175000017500000000053512740776544021652 0ustar vagrantvagrantpackage Example::Model::Address; use base qw/DBIx::SearchBuilder::Record/; # Class and instance method sub Table { "Addresses" } # Class and instance method sub Schema { return { Name => { TYPE => 'varchar', }, Phone => { TYPE => 'varchar', }, EmployeeId => { REFERENCES => 'Example::Model::Employee', }, } } 1;DBIx-SearchBuilder-1.67/ex/create_tables.pl0000644000175000017500000000323112740776544020422 0ustar vagrantvagrant#!/usr/bin/perl use strict; use warnings; # Note: this script does not actually *create* the tables; # however, it needs to connect to the database in order to # get the specific capabilities of your database (like type info). # CHANGE THIS TO FIT YOUR DATABASE: my @CONNECT_ARGS = ( Driver => 'Pg', Database => 'test', Host => 'localhost', User => 'postgres', Password => '', ); use DBIx::SearchBuilder::Handle; use DBIx::SearchBuilder::SchemaGenerator; my $BaseClass; BEGIN { unless (@ARGV) { die < $BaseClass, sub_name => 'models', instantiate => 'new'; my $handle = DBIx::SearchBuilder::Handle->new; $handle->Connect( @CONNECT_ARGS ); my $SG = DBIx::SearchBuilder::SchemaGenerator->new($handle); die "Couldn't make SchemaGenerator" unless $SG; for my $model (__PACKAGE__->models) { my $ret = $SG->AddModel($model); $ret or die "couldn't add model $model: ".$ret->error_message; } print $SG->CreateTableSQLText; DBIx-SearchBuilder-1.67/inc/0000755000175000017500000000000012743225026015411 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/inc/Module/0000755000175000017500000000000012743225026016636 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/inc/Module/Install/0000755000175000017500000000000012743225026020244 5ustar vagrantvagrantDBIx-SearchBuilder-1.67/inc/Module/Install/Win32.pm0000644000175000017500000000340312743225017021504 0ustar vagrantvagrant#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; DBIx-SearchBuilder-1.67/inc/Module/Install/Metadata.pm0000644000175000017500000004330212743225017022324 0ustar vagrantvagrant#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; DBIx-SearchBuilder-1.67/inc/Module/Install/Include.pm0000644000175000017500000000101512743225017022162 0ustar vagrantvagrant#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; DBIx-SearchBuilder-1.67/inc/Module/Install/Base.pm0000644000175000017500000000214712743225017021460 0ustar vagrantvagrant#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.16'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 DBIx-SearchBuilder-1.67/inc/Module/Install/Makefile.pm0000644000175000017500000002743712743225017022334 0ustar vagrantvagrant#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 DBIx-SearchBuilder-1.67/inc/Module/Install/Can.pm0000644000175000017500000000615712743225017021314 0ustar vagrantvagrant#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 DBIx-SearchBuilder-1.67/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612743225017022335 0ustar vagrantvagrant#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @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; DBIx-SearchBuilder-1.67/inc/Module/Install/AutoInstall.pm0000644000175000017500000000416212743225017023044 0ustar vagrantvagrant#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; DBIx-SearchBuilder-1.67/inc/Module/Install/Fetch.pm0000644000175000017500000000462712743225017021644 0ustar vagrantvagrant#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.16'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; DBIx-SearchBuilder-1.67/inc/Module/Install.pm0000644000175000017500000003021712743225017020605 0ustar vagrantvagrant#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.16'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. DBIx-SearchBuilder-1.67/inc/Module/AutoInstall.pm0000644000175000017500000006231112743225017021436 0ustar vagrantvagrant#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.16'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::getcwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::getcwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1197 DBIx-SearchBuilder-1.67/Makefile.PL0000755000175000017500000000124112740776544016630 0ustar vagrantvagrantuse inc::Module::Install; name ('DBIx-SearchBuilder'); all_from('lib/DBIx/SearchBuilder.pm'); requires('DBI'); requires('Want'); requires('Encode' => '1.99'); requires('Class::ReturnValue', 0.40); requires('Cache::Simple::TimedExpiry' => '0.21'); requires('Clone'); requires('Scalar::Util'); build_requires('Test::More' => 0.52); build_requires('DBD::SQLite'); build_requires('File::Temp'); features( 'Lower case API' => [ -default => 0, 'capitalization' => '0.03', ], 'Schema generation' => [ -default => 1, 'DBIx::DBSchema' => '', 'Class::Accessor' => '', ], ); auto_install(); no_index directory => 't'; no_index directory => 'ex'; sign; WriteAll(); DBIx-SearchBuilder-1.67/ROADMAP0000644000175000017500000000522712740776544015671 0ustar vagrantvagrantThings should/could be done in 1.x releases: * cover as much as possible code with tests * IsLast is not consistent(see t/01records.t) * LoadFromHash doesn't return any errors as other Load* methods do ** it should report back missing PK fields * Don't prevent DBI from die or reporting errors, now we have control with RaiseErrors and PrintErrors in Handle.pm. We should just check for $sth is defined and check $sth->err if fetch* methods returns undef. ** partly fixed * Count&CountAll: ** Count should always return how much rows we can fetch with Next, using pages affect this. ** CountAll should always return how many records we can fetch with applied conditions no matter use we pages or not to fetch it. ** document differences of the methods * More support for compound PKs. Known bugs: * CountAll corner case: * new collection * CounAll returns 0 * Limit collection * CountAll returns correct value * UnLimit or apply other limit(only change must_redo_search) * CountAll returns old value Could be fixed in one line change in CountAll sub, but interfere with Pages. When you call NextPage or other page walking methods must_redo_search bcomes true also so CountAll after NextPage force useless query. Things should be done in 2 release: * switch to lover case API ** patch capitalization.pm to support converting from lower case to upper. * Class::ReturnValue is prefered way to handle errors, should implement it in all error paths. * rework&review pages support, now I can't write next code: while( $records->NextPage ) { while( my $rec = $records->Next ) { ... } } * New methods: Prev, Current. Refactor collection walking: ** $sb->{itemscount} can be undef, what means that we are in the begin or end of the set. ** Current, returns undef if $sb->{itemscount} is undef, in other case returns record from array using $sb->{itemscount} as index. ** IsLast and IsFirst return undef if Current is not defined, and return 0 or 1 in other cases. ** First and Last - work as before, return undef or object. ** GotoItem supports undef as argument and returns undef or object. ** Next walks forward, returns first object if Current is undef, if there is no Next in set drops $sb->{itemscount} to undef and returns undef. ** Prev walks backward and works like Next, but if Current is undef it starts from Last record. DBIx-SearchBuilder-1.67/Changes0000644000175000017500000005046312743225011016135 0ustar vagrantvagrantRevision history for Perl extension DBIx::SearchBuilder. 1.67 - Add ->QueryHint and ->QueryHintFormatted to collection API for Oracle 1.66 - No changes since 1.65_02 1.65_02 - Stop unilaterally disabling the "UTF8" flag before executing queries - Make ->Fields case-sensitive in the column names it returns, as well as in the table name it takes. 1.65_01 - Make ->Fields only lookup information on the table requested, not all fields, for performance. It also is now case-sensitive in table name. - Omit calls to ->Fields entirely for PostgreSQL 9.1 and above 1.65 2013-07-03 - Bug fix for DateTimeInterval extraction on Pg 1.64 2013-07-01 - No changes since 1.63_03. Simply a non-dev release of everything since 1.63. 1.63_03 2013-06-14 - warn when rollback and commit are mixed - Handle->NullsOrder - skip timezone tests on SQLite when tzinfo is not there - skip tests if mysql can not do timezones - DISTINCT argument in Join method - DISTINCT argument in Join and NewAlias - Reset the iterator position whenever a search is run - Return the correct record from ->Last instead of the first record - Document the caveat of using GotoItem with a non-zero N 1.63_02 2013-04-17 - _Set now can take undef as argument to mean default or NULL. Still may result in error if default is not defined and no_nulls is true for the column. If old behaviour is required set $record->{'no_undefs_in_set'} to true value. - FUNCTION argument is now allowed in Limit. Code to combine FUNCTION, ALIAS and FIELD was refactored and unified in one place - CombineFunctionWithField method. Used in Column, GroupBy and Limit. This change should be backwards compatible. - Handle->DateTimeIntervalFunction 1.63_01 2013-03-27 - IN and NOT IN operators in ->Limit method - Add an AdditionalColumn method to collections - Add an AS parameter to Column method in collections - Consistent query generation by sorting hash keys/values 1.63 2012-09-14 - joins_are_distinct hint to indicate that distinct is not required for the current set of joins. 1.62 2012-03-26 - Bind values were ignored in SimpleUpdateFromSelect 1.61 2011-09-16 - 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 2011-09-15 - custom BuildDSN for Oracle - Database is treated as SID if SID is not provided - Build 'dbi:Oracle:' instead of 'dbi:Oracle:sid=' - changes in DBIx::SearchBuilder->Column method - complete documentation - support for empty FIELD argument - column naming fix when explicit ALIAS => 'main' passed 1.59 2010-11-19 - DBIx::SearchBuilder->DistinctFieldValues method 1.58 2010-10-20 - SIGNATURE fix - delete obsolete cvs metadata from a module 1.57 2010-09-04 - INCOMPATIBLE CHANGE: NextPage and PrevPage were adding rows from the previous page. Jesse claims that when he wrote this code, he was 20 years old and it seemed like a good idea at the time. - When logging queries, include full stack trace - support $sb->NewAlias( 'table' => 'LEFT' ); - allow join to depend on nothing - catch cases when there are more closing parens then should be - Oracle: Use ROW_NUMBER() to propagate row ordering from inside the DISTINCT - Various performance improvements through small internal refactorings - Implemented 'sub Fields' on Oracle - unify case insensitive characters to avoid using LOWER() in some cases - We now RedoSearch when RowsPerPage is changed - No longer RedoSearch if FirstRow is called, but is not actually changed - Document all paging functions and test them - handle LOWER() in redundant LEFT joins optimizer, for Oracle and may be Pg - Make debugging problems easier by passing errors back https://rt.cpan.org/Ticket/Display.html?id=55203 - fix Record->PrimaryKeys, field names in values hash are lc'ed https://rt.cpan.org/Ticket/Display.html?id=18280 - doc updates and cleanups 1.56 2009-07-17 - Don't use LOWER/ILIKE with dates, heuristic is used, but shouldn't harm other things - Don't apply DISTINCT on queries with group by, COUNT(DISTINCT x) is different and covered in Column method 1.55 2009-05-07 - Put test suite SQLite databases inside of tempdirs so they get garbage collected properly. Thanks to Andreas Koenig [rt.cpan.org #41322] - Allow ->Join to pre-existing collection object - Imlement and test SB::Handle::Fields - Pg can not guaranty order in the following queries: SELECT ... FROM (SELECT... ORDER BY ...) we use them to build distinct sets with ordering by columns in joined tables. Switched to group by instead of sub-selects. 1.54 2008-07-09 - When aborting transactions, we need to flush our cache, because SQLite is reusing the primary id for later inserts and the cache can otherwise become inconsistent. 1.53 2008-04-02 - Fix mysql version check in DistinctQuery function - Fix order by outer column on Oracle - Improve tests 1.52 2008-04-01 - Fix order by outer column on SQLite, mysql, adjust Pg. Add test that cover this. 1.51 2008-01-15 - Fix CountAll method when paging is enabled and data is in memory already 1.50 2007-11-23 - Oracle: Don't DISTINCT query when there is a group by clause - Fix a problem when we have more then two collections in a union and some of them are empty 1.49 2007-07-07 - Fix a CPAN signature issue 1.48 2007-03-11 - Fix a problem when left joins optimizer fails to calculate a boolean expression because of lower case aggregators. 1.47 2007-03-04 - Do the search in unions only when we must do them, not on every call to the Next method - Don't index ex/ dir to avoid complains by the indexer of PAUSE/CPAN 1.46 2007-02-25 - when doing a union, we need to actually search, rather than just doing a count - add support for testing with Oracle backend - Use CROSS JOIN instead of ',' as SQL parsers in Pg and some mysql are buggy and cannot parse "FROM X, Y JOIN Z ON Z.f = X.f" - deprecate DEBUG method, it's still there but produce warning - fix CleanSlate method that was missing several keys - fix a long standing bug we had, we didn't write depends_on data about a join, so we could build queries with incorrect parens around join conditions - fix default values for ALIAS1 argument in the Join method, istead of defaulting FIELD1 to 'main' value - fix a TODO test - internal refactoring of a storage for query's conditions, instead of building query strings right after the limit or join, we now build a perl structure - don't clone attributes that don't exists in the Clone method - we use Encode module without perl version check for a long time, so we can get rid of all checks for the version and load the module at compile time everywhere we need it - implement MayBeNull method in the handler that checks if applied conditions allow NULLs in the result set - implement cascaded LEFT JOINs optimization - additional tests for CleanSlate and Clone methods, ENTRY_AGGREGATOR argument, different types of joins and LEFT JOIN optimizer 1.45 2006-09-26 - Postgres: fix "$rec->Create();" - Postgres: fix "$rec->Create( IntegerColumn => '' );" - Postgres: fix "$rec->SetIntegerColumn( '' );" - Postgres: add test - cleanup ::Record::Cachable - use cache in: $a->LoadByCols(...); $b->LoadById( $a->id ); - add cache tests 1.44 2006-05-27 - DBIx::SearchBuilder::Handle::DatabaseVersion enhancements 1.43 2006-04-12 - Fix to the sequence compatibility fixes. For backwards compatibility. 1.42 2006-04-10 - Signatures fixed 1.41 2006-04-10 - PG 8.1 sequence compatibility fixes from Daniel Tabuenca 1.40 2006-03-10 - 'NOT STARTSWITH' and 'NOT ENDSWITH' 1.39 2006-02-16 - Allow ORs on left joins 1.38 2005-12-29 - Released 1.37 dev series 1.37_01 2005-12-08 - Switched Postgres sequence lookups to use CURRVAL, rather than OIDs 1.36 2005-12-02 - Change to how we resolve virtual columns to deal with a "no such attribute" bug in RT 1.35 2005-11-02 - Doc fixes and OrderBy cleanup from ruslan 1.34 2005-11-02 - Clone support from Ruslan 1.33 2005-09-22 - Better SQL statement logging from alex 1.32 2005-09-01 - DBD::SQLite is necessary for the test suite to run correctl 1.31 2005-07-29 - Updated MANIFEST to fix a build issue - Thanks to Andy Lester and David Glasser 1.30_03 2005-06-09 - Significant new tests from Ruslan Zakirov and Dave Glasser - You no longer need to explicitly bless a DBIx::SearchBuilder::Handle subclass - Start of a major overhaul of the subclass API for DBIx::SearchBuilder::Record objects. A new "schema" method will define the data in _ClassAccessible and also generate database schema using DBIx::DBSchema. - for numeric types, make the empty check be "null or 0", not "null or ''" - New search tests from ruslan - added an init_data method to t/utils.pl - CleanSlate doesnt init show_rows - CleanSlate doesnt clean _{open|close}_parens - get rid of stupid ifs in CleanSlate - get rid of evals in _DoSearch and _DoCount, use Handle methods to control DBI error handling - rewrite LoadByPrimaryKeys args handling to consistent with other Load* methods - report error when PK filed is missing in LoadByPrimaryKeys - fix warning in __Set methods when newvalue is undef - small code cleanups - test coverage grows from 75.2% to 84.7% for Record.pm 1.30_02 2005-05-22 - Lots of patches from Ruslan: First and main change is using of `goto &$AUTOLOAD` syntax, that helps avoid code duplication and hides AUTOLOAD sub from stack trace. I think this also would help implement CompileAllAutoSubs method easier. - It's also one of the steps to better tests coverage. - Test coverage for Record.pm grows from 66% to 75.2%. - _LoadFromSQL never reported error when PK fields are missed. Fixed. - fetchrow_hashref dies only when RaiseErrors is true, because we can control this from Handle obj so we should die according to $Handle->RaiseErrors property. Fixed. - When RaiseErrors is "false" then fetchrow_hashref returns undef and we should check $sth->err(see `perldoc DBI`). Fixed. - After call to fetchrow we should clean "fetched" internal hash and fill it only when we return successful result. Fixed. - If SimpleQuery fails, _LoadFromSQL method doesn't return any error message. Fixed. 1.30_01 2005-05-16 - Patches from Ruslan to switch to using 'capitalization.pm' for our regular_case subroutine aliases 1.30 2005-07-28 - Removed {{{ and }}} fold markers. Patch from Ruslan 1.27 2005-05-08 - Added supoprt for functions containing "?" to represent the parameter in ->Column() - Added better support for functional columns in search listings and group by clauses 1.26 2005-04-17 - Added support for expression based left joins 1.25 2005-04-09 - Backed out a change introduced in 1.23 that caused table and column names to be quoted, causing Postgres to flip out. 1.24 2005-04-06 - Added a new "SearchBuilder::Unique" module for uniquifying search results 1.23 - Now use DBI->quote_identifier to quote column and table names (Ruslan) - Test suite updates (Ruslan) 1.22 2005-01-24 - Require encode since we require encode. 1.21 2005-01-22 - Oracle LOB handling caused us to corrupt item values on update. - Just before inserting things into the database, turn off their utf8 flag. The flag didn't have any positve impact _and_ it can take down recent DBD::Oracle releases. (This is a new failure in DBD::Oracle 1.16) 1.20 2005-01-18 - Minor test suite fixes from Ruslan. 1.19 2005-01-08 - Performing a search multiple times could result in multiple copies of records in a collection. Uncovered thanks to Kevin Chen and Alex Vandiver. 1.18 - Release the changes from 1.17 1.17_03 - Properly mark BLOB columns in UPDATE calls. (DBD::Oracle 1.16 broke without this) 1.17_02 - Better handling of empty values for SB::Record::_Accessible. ( --Ruslan) 1.17_01 - More record tests from Ruz 1.16 2004-12-09 - Fixed a bug in D::SB::R::Cachable that could cause it to load the wrong row from the cache if you were loading by alternate keys and had since changed one of the attributes of a previous row. This was unmasked by a bug that Ruslan Zakirov found in RT 3.3's custom field handling 1.15 2004-11-27 - Fix a testsuite bug when DBD::SQLite isn't there 1.14 - Silenced warnings about uninitialized warnings when inserting null cols into the database. - Started adding lowercase method name aliases - Minor refactoring of 'id' method for a stupid, tiny perf improvement - Refactoring of DBIx::SearchBuilder::Record::Cachable for performance improvement - Added a FlushCache method to DBIx::SearchBuilder::Record::Cachable. - Started to flesh out a...test suite - SearchBuilder now truncates strings before inserting them into character types in the database as mysql generally does. Additionally, it truncates things at utf8 character boundaries...as mysql does not. - Fix for an undefined record cache warning on load from Autrijus Tang - Major documentation cleanups --Simon Cavalletto - A few tweaks to the ::Record class to eliminate the hard-coding of the name of the id column --Simon Cavalletto 1.12 - Better error handling for some query build failure cases - Corrected query builder for SQLite - More refactoring. 1.11 - When loading an object whose "id" has been altered, as in the case of RT's "Merge" functionality, the wrong object was returned by the caching layer. Special casing for the "id" method was removed. 1.10_05 - Reworked the _Accessible mechanism in DBIx::SearchBuilder::Record to remove a horribly crufty old caching mechanism that created a copy of the accessible hash for each and every object instantiated, sometimes quite slowly. 1.10_04 2004-08-30 - A query builder fix for an issue that bit RT2: Unsatisfied dependency chain in Joins Users_2 at /usr/local/share/perl/5.8.3/DBIx/SearchBuilder/Handle.pm line 965, line 69. 1.10_03 2004-08-30 - Cache Sanity fixes from Autrijus Tang 1.10_02 2004-08-26 1.10_01 2004-08-26 - Reimplemented DBIx::SearchBuilder:::Record::Cachable to use Cache::Simple::TimedExpiry. This should make it faster and more memory efficient. 1.10 - Identical to 1.10_05 1.02_03 2004-07-22 - Additional bullet proofing for joins. Now we default to ALIAS1 being "main" (cubic@acronis.ru) 1.02_02 2004-07-20 - Fixed a join bug that mostly manifests as a 'Dependency chain' error on RT2. 1.02_01 2004-07-07 - magic _Object instantiation from cubic@acronis.ru - make SB::_Handle settable directly (cubic@acronis.ru) - document the above 1.01 2004-06-27 - Releasing 1.00_06 as stable 1.00_06 - Pg/Oracle: Don't attempt to do case insensitive comparisons on integer values. 1.00_05 - Force utf8 flag on when doing searches for utf8 data; this is a workaround for DBDs that don't do it themselves. 1.00_04 - Move Postgres specific join behaviour to the superclass so everyone gets the benefit. 1.00_03 - Remove "AS" from table name aliases on joins, since Oracle doesn't like em. 1.00_02 - Slightly cleaner code in SearchBuilder->GotoPage 1.00_01 - Better handling of case insensitive comparisons on Postgres - Proper support for query paging on SQLite 0.99 - Bundled changes from 0.98* and released production version - Removed duplicate code in cache expiry routines Experimental SearchBuilder::Union collection object. - Released at the YAPC::Taipei::22004 Release Party 0.98_04 - New mysql/oracle "Join" code that allows more complex bundling of joins from Linda and Robert 0.98_03 - New test infrastructure from Andy Lester 0.98_02 - Better handling of != clauses on Postgres 0.97_02 - Support for "Group By" clauses. - Support for delayed load of certain columns from Autrijus Tang. 0.97_01 - Oracle doesn't support binary-safe clobs in a reasonable manner. 0.96_01 - Fix a couple of spurious warnings in Record::Cachable - Records loaded from multiple-record searches were never cached - correctly 0.96 - Releasing 0.96_01 as usable 0.95_03 - Allow case-insensitive loading by columns in SearchBuilder::Record - Record::LoadByCols now lets you specify operator and values 0.95_01 - Removed historical escaping for non-ascii searche queries 0.94 - Fix for multiple handles in one app from Autrijus Tang 0.93 - Added ODBC database driver from Autrijus Tang - Added the ability to sort on functions of columns from Autrijus Tang - Improved case-insensitve searching behavior for PostgreSQL - Added support for multiple handles in one app from Autrijus Tang (#4167) - Added initial Informix database driver from Oliver Tappe 0.92 2003-09-04 - Fixed a bug that caused certain types of pre-canned table aliases to fail to work on join 0.90 2003-08-08 - Disable Class::ReturnValue's stack trace feature as it interacted poorly with a stack containing lots of data 0.89_02 2003-07-19 - Patch from Grant DeGraw to allow ordering by multiple columns. 0.89_01 2003-07-18 - Patch from Brook for: - better oracle support - remove "SELECT DISTINCT" when it's not necessary 0.88 2003-06-23 - More correct generation of "Distinct" keyword on counts for queries with left joins 0.87 2003-06-16 - Changed DBIx::SB::Record::Cachable to expire cached object when a "deeper" method call changes their values 0.86 2003-06-07 - Doing conditional connections was failing on postgres, because the handle was defined, but not connected 0.85 2003-06-07 - Stan's destroy fix was actually badly breaking RT - It's now an optional parameter. 0.84 2003-06-04 - Bumped the version for release 0.83_05 2003-06-02 - Provide support for blowing away nested transactions that aren't yet committed. 0.83_04 2003-06-02 - Fixed how values of returned hashes are downcased. - Should be a minor perf improvement 0.83_03 2003-05-30 - Moved Stan's destryo fix to the right file 0.83_02 2003-05-27 - Better oracle support for unique ids on indexes from Brook 0.83_01 2003-05-27 - Stan's DESTROY fix - Mathieu Arnold's patch to make function naming for autoloaded functions a bit more flexible 0.82 2003-05-19 - Query builder changes to improve some join performance - Fixes to a tight loop for cache expiry 0.81_04 2003-04-14 - Fixed a bug in "Distinct" logic introduced in 0.81_01 0.81_03 2003-04-13 - Patches for Oracle BLOB support from Brook Schofield 0.81_02 2003-04-13 - Rebuilt Postgres query generator. 0.81_01 2003-03-27 - Select Distinct altered to support oracle 0.80 2003-03-08 - Count method enhanced to ignore "LIMIT"s - LIMIT behaviour changed to be handle specific 0.79 2003-01-19 - ReadableAttributes and WritableAttributes added as methods to Record.pm 0.78 2003-01-16 - SB->Count should return no results unless the search is limited - Eliminate a warning on empty searches 0.77 2003-01-15 - No longer attempt to cache (and fail) objects that haven't been database-loaded 0.76 2002-12-30 - Extra checking for cache misses in DBIx::SearchBuilder::Record::Cachable - The start of support for checking database version, so that we can do version-specific SQL - A patch from Autrijus Tang that allows utf-8 safe searching 0.75 2002-12-06 - Applying a patch from Rob Spier which enables arbitrarily complex grouping clauses. It's a hack, but we love it anyway....at least until SB gets redone with proper arbitrarily complex query generation. 0.74 2002-10-11 - Adding support for mysqlPP 0.73 2002-09-10 - More class-returnvalue ification - Fixed a caching bug that caused multiple copies of an object in memory to not be kept in sync 0.72 2002-08-28 - Fixed bug in setting a column to the value of an SQL statement. 0.70 2002-08-27 - Better support for Postgres 7.2 and transactions. 0.62 2002-07-05 - Support for Class::ReturnValue to channel errors up when expected - Dependency on Class::ReturnValue - Minor cleanups and refactorings to allow percolation of errors on create 0.34 2001-05-23 - SearchBuilder.pm - refactored to allow LEFT joins. 0.31 2001-05-12 - SearchBuilder::Record::Cachable now constructs cache keys in a way that doesn't lose when records in different tables have the same keys. 0.30 2001-05-11 - Added DBIx::SearchBuilder::Record::Cachable from - Changed SearchBuilder->Count to do the right thing if no query has been performed - No longer specify a sort order if no sort order was specified ;) 0.01 2000-08-29 - original version; created by h2xs 1.19