DBIx-SearchBuilder-1.65/0000700000175000017500000000000012165133403013111 5ustar tomtomDBIx-SearchBuilder-1.65/META.yml0000644000175000017500000000141212165133400014367 0ustar tomtom--- abstract: 'Encapsulate SQL queries and rows in simple perl objects' author: - 'Jesse Vincent ' 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.06' 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 resources: license: http://dev.perl.org/licenses/ version: 1.65 DBIx-SearchBuilder-1.65/lib/0000700000175000017500000000000012165133403013657 5ustar tomtomDBIx-SearchBuilder-1.65/lib/DBIx/0000700000175000017500000000000012165133403014445 5ustar tomtomDBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder.pm0000755000175000017500000013405612165133145017550 0ustar tomtom package DBIx::SearchBuilder; use strict; use warnings; our $VERSION = "1.65"; 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 ); #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 ); } =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 ); # 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 main.* FROM $QueryString"; $QueryString .= $clause; $QueryString .= $self->_OrderClause; } elsif ( !$self->{'joins_are_distinct'} && $self->_isJoined ) { $self->_DistinctQuery(\$QueryString); } else { $QueryString = "SELECT 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); } else { $QueryString = "SELECT 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 $column = 'main.'. $args{'Field'}; $query_string = 'SELECT 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, lowercased. TODO: Why are they lowercased? =cut sub Fields { return (shift)->_Handle->Fields( @_ ); } =head2 HasField { TABLE => undef, FIELD => undef } Returns true if TABLE has field FIELD. Return false otherwise =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}; } =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 Copyright (c) 2001-2006 Jesse Vincent, jesse@bestpractical.com. All rights reserved. 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.65/lib/DBIx/SearchBuilder/0000700000175000017500000000000012165133403017161 5ustar tomtomDBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Util.pm0000644000175000017500000000156112143046615020455 0ustar tomtomuse strict; use warnings; package DBIx::SearchBuilder::Util; use base 'Exporter'; our @EXPORT_OK = qw( sorted_values ); =head1 NAME DBIx::SearchBuilder::Util - Utility and convenience functions for DBIx::SearchBuilder =head1 SYNOPSIS use DBIx::SearchBuilder::Util qw( sorted_values ); # or other function you want =head1 EXPORTED FUNCTIONS =head2 sorted_values Takes a hash or hashref and returns the values sorted by their respective keys. Equivalent to map { $hash{$_} } sort keys %hash but far more convenient. =cut sub sorted_values { my $hash = @_ == 1 ? $_[0] : { @_ }; return map { $hash->{$_} } sort keys %$hash; } =head1 LICENSE AND COPYRIGHT Copyright (c) 2013 Best Practical Solutions, LLC. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Unique.pm0000644000175000017500000000320712071136620021001 0ustar tomtompackage 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; # Prepend select query for DBs which allow DISTINCT on all column types. $$statementref = "SELECT 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; # Prepend select query for DBs which allow DISTINCT on all column types. $$statementref = "SELECT COUNT(DISTINCT main.id) FROM $$statementref"; } sub Fields { my $self = shift; my $table = shift; unless ( keys %FIELDS_IN_TABLE ) { my $sth = $self->dbh->column_info( undef, '', '%', '%' ) or return (); my $info = $sth->fetchall_arrayref({}); foreach my $e ( @$info ) { push @{ $FIELDS_IN_TABLE{ lc $e->{'TABLE_NAME'} } ||= [] }, lc $e->{'COLUMN_NAME'}; } } return @{ $FIELDS_IN_TABLE{ lc $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.65/lib/DBIx/SearchBuilder/Record/0000700000175000017500000000000012165133403020377 5ustar tomtomDBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Record/Cachable.pm0000755000175000017500000001607612071136620022446 0ustar tomtom# $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Record/Cachable.pm,v 1.6 2001/06/19 04:22:32 jesse Exp $ # by Matt Knopp package DBIx::SearchBuilder::Record::Cachable; use strict; use warnings; use DBIx::SearchBuilder::Handle; use Cache::Simple::TimedExpiry; use base qw(DBIx::SearchBuilder::Record); =head1 NAME DBIx::SearchBuilder::Record::Cachable - Records with caching behavior =head1 SYNOPSIS package MyRecord; use base qw/DBIx::SearchBuilder::Record::Cachable/; =head1 DESCRIPTION This module subclasses the main L package to add a caching layer. The public interface remains the same, except that records which have been loaded in the last few seconds may be reused by subsequent fetch or load methods without retrieving them from the database. =head1 METHODS =cut my %_CACHES = (); sub _SetupCache { my ($self, $cache) = @_; $_CACHES{$cache} = Cache::Simple::TimedExpiry->new(); $_CACHES{$cache}->expire_after( $self->_CacheConfig->{'cache_for_sec'} ); return $_CACHES{$cache}; } =head2 FlushCache This class method flushes the _global_ DBIx::SearchBuilder::Record::Cachable cache. All caches are immediately expired. =cut sub FlushCache { %_CACHES = (); } =head2 _FlushKeyCache Blow away this record type's key cache =cut sub _FlushKeyCache { my $self = shift; my $cache = ($self->{_class}||= ref($self))."-KEYS"; return $self->_SetupCache($cache); } sub _KeyCache { my $self = shift; my $cache = ($self->{_class}||= ref($self))."-KEYS"; return $_CACHES{$cache} || $self->_SetupCache($cache); } sub _RecordCache { my $self = shift; my $cache = ($self->{_class}||= ref($self)); return $_CACHES{$cache} || $self->_SetupCache($cache); } # Function: LoadFromHash # Type : (overloaded) public instance # Args : See DBIx::SearchBuilder::Record::LoadFromHash # Lvalue : array(boolean, message) sub LoadFromHash { my $self = shift; # Blow away the primary cache key since we're loading. $self->{'_SB_Record_Primary_RecordCache_key'} = undef; my ( $rvalue, $msg ) = $self->SUPER::LoadFromHash(@_); ## Check the return value, if its good, cache it! $self->_store if $rvalue; return ( $rvalue, $msg ); } # Function: LoadByCols # Type : (overloaded) public instance # Args : see DBIx::SearchBuilder::Record::LoadByCols # Lvalue : array(boolean, message) sub LoadByCols { my ( $self, %attr ) = @_; # Blow away the primary cache key since we're loading. $self->{'_SB_Record_Primary_RecordCache_key'} = undef; # generate the alternate cache key my $alt_key = $self->_gen_alternate_RecordCache_key(%attr); # get primary cache key my $cache_key = $self->_lookup_primary_RecordCache_key($alt_key); if ( $cache_key && $self->_fetch( $cache_key ) ) { return ( 1, "Fetched from cache" ); } # Fetch from the DB! my ( $rvalue, $msg ) = $self->SUPER::LoadByCols(%attr); # Check the return value, if its good, cache it! if ($rvalue) { $self->_store(); # store alt_key as alias for pk $self->_KeyCache->set( $alt_key, $self->_primary_RecordCache_key); } return ( $rvalue, $msg ); } # Function: __Set # Type : (overloaded) public instance # Args : see DBIx::SearchBuilder::Record::_Set # Lvalue : ? sub __Set () { my $self = shift; $self->_expire; return $self->SUPER::__Set( @_ ); } # Function: Delete # Type : (overloaded) public instance # Args : nil # Lvalue : ? sub __Delete () { my $self = shift; $self->_expire; return $self->SUPER::__Delete( @_ ); } # Function: _expire # Type : private instance # Args : string(cache_key) # Lvalue : 1 # Desc : Removes this object from the cache. sub _expire (\$) { my $self = shift; my $cache_key = $self->_primary_RecordCache_key or return; $self->_RecordCache->set( $cache_key, undef, time-1 ); # We should be doing something more surgical to clean out the # key cache. but we do need to expire it $self->_FlushKeyCache; } # Function: _fetch # Type : private instance # Args : string(cache_key) # Lvalue : 1 # Desc : Get an object from the cache, and make this object that. sub _fetch () { my ( $self, $cache_key ) = @_; my $data = $self->_RecordCache->fetch( $cache_key ) or return 0; @{$self}{keys %$data} = values %$data; # deserialize return 1; } # Function: _store # Type : private instance # Args : string(cache_key) # Lvalue : 1 # Desc : Stores this object in the cache. sub _store (\$) { my $self = shift; my $key = $self->_primary_RecordCache_key or return 0; $self->_RecordCache->set( $key, $self->_serialize ); return 1; } sub _serialize { my $self = shift; return { values => $self->{'values'}, table => $self->Table, fetched => $self->{'fetched'} }; } # Function: _gen_alternate_RecordCache_key # Type : private instance # Args : hash (attr) # Lvalue : 1 # Desc : Takes a perl hash and generates a key from it. sub _gen_alternate_RecordCache_key { my ( $self, %attr ) = @_; my $cache_key = ''; foreach my $key ( sort keys %attr ) { my $value = $attr{$key}; unless ( defined $value ) { $value = '=__undef'; } elsif ( ref($value) eq "HASH" ) { $value = ( $value->{operator} || '=' ) . ( defined $value->{value}? $value->{value}: '__undef' ); } else { $value = "=" . $value; } $cache_key .= $key . $value . ','; } chop($cache_key); return ($cache_key); } # Function: _primary_RecordCache_key # Type : private instance # Args : none # Lvalue: : 1 # Desc : generate a primary-key based variant of this object's cache key # primary keys is in the cache sub _primary_RecordCache_key { my ($self) = @_; return $self->{'_SB_Record_Primary_RecordCache_key'} if $self->{'_SB_Record_Primary_RecordCache_key'}; my $cache_key = ''; my %pk = $self->PrimaryKeys; foreach my $key ( sort keys %pk ) { my $value = $pk{$key}; return undef unless defined $value; $cache_key .= $key . '=' . $value .','; } chop $cache_key; return $self->{'_SB_Record_Primary_RecordCache_key'} = $cache_key; } # Function: lookup_primary_RecordCache_key # Type : private class # Args : string(alternate cache id) # Lvalue : string(cache id) sub _lookup_primary_RecordCache_key { my ($self, $key) = @_; return undef unless $key; return $self->_KeyCache->fetch($key) || $key; } =head2 _CacheConfig You can override this method to change the duration of the caching from the default of 5 seconds. For example, to cache records for up to 30 seconds, add the following method to your class: sub _CacheConfig { { 'cache_for_sec' => 30 } } =cut sub _CacheConfig { return { 'cache_p' => 1, 'cache_for_sec' => 5, }; } 1; __END__ =head1 AUTHOR Matt Knopp =head1 SEE ALSO L, L =cut DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Union.pm0000644000175000017500000001035012071136620020620 0ustar tomtompackage DBIx::SearchBuilder::Union; use strict; use warnings; # WARNING --- This is still development code. It is experimental. our $VERSION = '0'; # This could inherit from DBIx::SearchBuilder, but there are _a lot_ # of things in DBIx::SearchBuilder that we don't want, like Limit and # stuff. It probably makes sense to (eventually) split out # DBIx::SearchBuilder::Collection to contain all the iterator logic. # This could inherit from that. =head1 NAME DBIx::SearchBuilder::Union - Deal with multiple SearchBuilder result sets as one =head1 SYNOPSIS use DBIx::SearchBuilder::Union; my $U = new DBIx::SearchBuilder::Union; $U->add( $tickets1 ); $U->add( $tickets2 ); $U->GotoFirstItem; while (my $z = $U->Next) { printf "%5d %30.30s\n", $z->Id, $z->Subject; } =head1 WARNING This module is still experimental. =head1 DESCRIPTION Implements a subset of the DBIx::SearchBuilder collection methods, but enough to do iteration over a bunch of results. Useful for displaying the results of two unrelated searches (for the same kind of objects) in a single list. =head1 METHODS =head2 new Create a new DBIx::SearchBuilder::Union object. No arguments. =cut sub new { bless { data => [], curp => 0, # current offset in data item => 0, # number of indiv items from First count => undef, }, shift; } =head2 add $sb Add a searchbuilder result (collection) to the Union object. It must be the same type as the first object added. =cut sub add { my $self = shift; my $newobj = shift; unless ( @{$self->{data}} == 0 || ref($newobj) eq ref($self->{data}[0]) ) { die "All elements of a DBIx::SearchBuilder::Union must be of the same type. Looking for a " . ref($self->{data}[0]) ."."; } $self->{count} = undef; push @{$self->{data}}, $newobj; } =head2 First Return the very first element of the Union (which is the first element of the first Collection). Also reset the current pointer to that element. =cut sub First { my $self = shift; die "No elements in DBIx::SearchBuilder::Union" unless @{$self->{data}}; $self->{curp} = 0; $self->{item} = 0; $self->{data}[0]->First; } =head2 Next Return the next element in the Union. =cut sub Next { my $self=shift; my $goto_first = 0; while ( my $cur = $self->{'data'}[ $self->{'curp'} ] ) { $cur->GotoFirstItem if $goto_first; my $res = $cur->Next; if ( $res ) { $self->{'item'}++; return $res; } $goto_first = 1; $self->{'curp'}++; } return undef; } =head2 Last Returns the last item =cut sub Last { die "Last doesn't work right now"; my $self = shift; $self->GotoItem( ( $self->Count ) - 1 ); return ( $self->Next ); } =head2 Count Returns the total number of elements in the Union'ed Collection =cut sub Count { my $self = shift; my $sum = 0; # cache the results return $self->{count} if defined $self->{count}; $sum += $_->Count for (@{$self->{data}}); $self->{count} = $sum; return $sum; } =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); } sub GotoItem { my $self = shift; my $item = shift; die "We currently only support going to the First item" unless $item == 0; $self->{curp} = 0; $self->{item} = 0; $self->{data}[0]->GotoItem(0); return $item; } =head2 IsLast Returns true if the current row is the last record in the set. =cut sub IsLast { my $self = shift; $self->{item} == $self->Count ? 1 : undef; } =head2 ItemsArrayRef Return a refernece to an array containing all objects found by this search. Will destroy any positional state. =cut sub ItemsArrayRef { my $self = shift; return [] unless $self->Count; $self->GotoFirstItem(); my @ret; while( my $r = $self->Next ) { push @ret, $r; } return \@ret; } =head1 AUTHOR Copyright (c) 2004 Robert Spier All rights reserved. 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 =cut 1; __END__ DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Handle/0000700000175000017500000000000012165133403020354 5ustar tomtomDBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Handle/mysql.pm0000755000175000017500000001761012143046615022105 0ustar tomtom# $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/mysql.pm,v 1.8 2001/10/12 05:27:05 jesse Exp $ package DBIx::SearchBuilder::Handle::mysql; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::mysql - A mysql specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of MySQL. =head1 METHODS =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. If the insert succeeds, returns the id of the insert, otherwise, returns a Class::ReturnValue object with the error reported. =cut sub Insert { my $self = shift; my $sth = $self->SUPER::Insert(@_); if (!$sth) { return ($sth); } $self->{'id'}=$self->dbh->{'mysql_insertid'}; # Yay. we get to work around mysql_insertid being null some of the time :/ unless ($self->{'id'}) { $self->{'id'} = $self->FetchResult('SELECT LAST_INSERT_ID()'); } warn "$self no row id returned on row creation" unless ($self->{'id'}); return( $self->{'id'}); #Add Succeded. return the id } =head2 SimpleUpdateFromSelect Customization of L. Mysql doesn't support update with subqueries when those fetch data from the table that is updated. =cut sub SimpleUpdateFromSelect { my ($self, $table, $values, $query, @query_binds) = @_; return $self->SUPER::SimpleUpdateFromSelect( $table, $values, $query, @query_binds ) unless $query =~ /\b\Q$table\E\b/i; my $sth = $self->SimpleQuery( $query, @query_binds ); return $sth unless $sth; my (@binds, @columns); for my $k (sort keys %$values) { push @columns, $k; push @binds, $values->{$k}; } my $update_query = "UPDATE $table SET " . join( ', ', map "$_ = ?", @columns ) .' WHERE ID IN '; return $self->SimpleMassChangeFromSelect( $update_query, \@binds, $query, @query_binds ); } sub DeleteFromSelect { my ($self, $table, $query, @query_binds) = @_; return $self->SUPER::DeleteFromSelect( $table, $query, @query_binds ) unless $query =~ /\b\Q$table\E\b/i; return $self->SimpleMassChangeFromSelect( "DELETE FROM $table WHERE id IN ", [], $query, @query_binds ); } sub SimpleMassChangeFromSelect { my ($self, $update_query, $update_binds, $search, @search_binds) = @_; my $sth = $self->SimpleQuery( $search, @search_binds ); return $sth unless $sth; # tried TEMPORARY tables, much slower than fetching and delete # also size of ENGINE=MEMORY is limitted by option, on disk # tables more slower than in memory my $res = 0; my @ids; while ( my $id = ($sth->fetchrow_array)[0] ) { push @ids, $id; next if @ids < 1000; my $q = $update_query .'('. join( ',', ('?')x@ids ) .')'; my $sth = $self->SimpleQuery( $q, @$update_binds, splice @ids ); return $sth unless $sth; $res += $sth->rows; } if ( @ids ) { my $q = $update_query .'('. join( ',', ('?')x@ids ) .')'; my $sth = $self->SimpleQuery( $q, @$update_binds, splice @ids ); return $sth unless $sth; $res += $sth->rows; } return $res == 0? '0E0': $res; } =head2 DatabaseVersion Returns the mysql version, trimming off any -foo identifier =cut sub DatabaseVersion { my $self = shift; my $v = $self->SUPER::DatabaseVersion(); $v =~ s/\-.*$//; return ($v); } =head2 CaseSensitive Returns undef, since mysql's searches are not case sensitive by default =cut sub CaseSensitive { my $self = shift; return(undef); } sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; return $self->SUPER::DistinctQuery( $statementref, $sb, @_ ) if $sb->_OrderClause !~ /(?DatabaseVersion, 0, 1) == 4 ) { local $sb->{'group_by'} = [{FIELD => 'id'}]; my ($idx, @tmp, @specials) = (0, ()); foreach ( @{$sb->{'order_by'}} ) { if ( !exists $_->{'ALIAS'} || ($_->{'ALIAS'}||'') eq "main" ) { push @tmp, $_; next; } push @specials, ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(". $_->{'ALIAS'} .".". $_->{'FIELD'} .")" ." __special_sort_$idx"; push @tmp, { ALIAS => '', FIELD => "__special_sort_$idx", ORDER => $_->{'ORDER'} }; $idx++; } local $sb->{'order_by'} = \@tmp; $$statementref = "SELECT ". join( ", ", 'main.*', @specials ) ." FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } else { local $sb->{'group_by'} = [{FIELD => 'id'}]; local $sb->{'order_by'} = [ map { ($_->{'ALIAS'}||'') ne "main" ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" } : $_ } @{$sb->{'order_by'}} ]; $$statementref = "SELECT main.* FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } } sub Fields { my $self = shift; my $table = shift; my $cache = \%DBIx::SearchBuilder::Handle::FIELDS_IN_TABLE; unless ( $cache->{ lc $table } ) { my $sth = $self->dbh->column_info( undef, undef, $table, '%' ) or return (); my $info = $sth->fetchall_arrayref({}); foreach my $e ( sort {$a->{'ORDINAL_POSITION'} <=> $b->{'ORDINAL_POSITION'}} @$info ) { push @{ $cache->{ lc $e->{'TABLE_NAME'} } ||= [] }, lc $e->{'COLUMN_NAME'}; } } return @{ $cache->{ lc $table } || [] }; } =head2 SimpleDateTimeFunctions Returns hash reference with specific date time functions of this database for L. =cut sub SimpleDateTimeFunctions { my $self = shift; return $self->{'_simple_date_time_functions'} ||= { %{ $self->SUPER::SimpleDateTimeFunctions(@_) }, datetime => '?', time => 'TIME(?)', hourly => "DATE_FORMAT(?, '%Y-%m-%d %H')", hour => 'HOUR(?)', date => 'DATE(?)', daily => 'DATE(?)', day => 'DAYOFMONTH(?)', dayofmonth => 'DAYOFMONTH(?)', monthly => "DATE_FORMAT(?, '%Y-%m')", month => 'MONTH(?)', annually => 'YEAR(?)', year => 'YEAR(?)', dayofweek => "DAYOFWEEK(?) - 1", # 1-7, 1 - Sunday dayofyear => "DAYOFYEAR(?)", # 1-366 weekofyear => "WEEK(?)", # skip mode argument, so it can be controlled in mysql config }; } =head2 ConvertTimezoneFunction Custom implementation of L. Use the following query to get list of timezones: SELECT Name FROM mysql.time_zone_name; Read docs about keeping timezone data up to date: http://dev.mysql.com/doc/refman/5.5/en/time-zone-upgrades.html =cut sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'} unless $args{From} && $args{'To'}; return $args{'Field'} if lc $args{From} eq lc $args{'To'}; my $dbh = $self->dbh; $_ = $dbh->quote( $_ ) foreach @args{'From', 'To'}; return "CONVERT_TZ( $args{'Field'}, $args{'From'}, $args{'To'} )"; } sub _DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); return "TIMESTAMPDIFF(SECOND, $args{'From'}, $args{'To'})"; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO DBIx::SearchBuilder, DBIx::SearchBuilder::Handle =cut DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Handle/Informix.pm0000644000175000017500000000631612071136620022525 0ustar tomtom# $Header: $ package DBIx::SearchBuilder::Handle::Informix; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::Informix - An Informix specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of Informix. =head1 METHODS =cut =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. If the insert succeeds, returns the id of the insert, otherwise, returns a Class::ReturnValue object with the error reported. =cut sub Insert { my $self = shift; my $sth = $self->SUPER::Insert(@_); if (!$sth) { print "no sth! (".$self->dbh->{ix_sqlerrd}[1].")\n"; return ($sth); } $self->{id}=$self->dbh->{ix_sqlerrd}[1]; warn "$self no row id returned on row creation" unless ($self->{'id'}); return( $self->{'id'}); #Add Succeded. return the id } =head2 CaseSensitive Returns 1, since Informix's searches are case sensitive by default =cut sub CaseSensitive { my $self = shift; return(1); } =head2 BuildDSN Builder for Informix DSNs. =cut sub BuildDSN { my $self = shift; my %args = ( Driver => undef, Database => undef, Host => undef, Port => undef, SID => undef, RequireSSL => undef, @_); my $dsn = "dbi:$args{'Driver'}:"; $dsn .= "$args{'Database'}" if (defined $args{'Database'} && $args{'Database'}); $self->{'dsn'}= $dsn; } =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; # XXX TODO THIS only works on the FIRST page of results. that's a bug if ($per_page) { $$statementref =~ s[^\s*SELECT][SELECT FIRST $per_page]i; } } sub Disconnect { my $self = shift; if ($self->dbh) { my $status = $self->dbh->disconnect(); $self->dbh( undef); return $status; } else { return; } } =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 $table = $sb->Table; if ($sb->_OrderClause =~ /(?_GroupClause; $$statementref .= $sb->_OrderClause; } 1; __END__ =head1 AUTHOR Oliver Tappe, oliver@akso.de =head1 SEE ALSO perl(1), DBIx::SearchBuilder =cut DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Handle/Pg.pm0000755000175000017500000002123312164604751021306 0ustar tomtom#$Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/Pg.pm,v 1.8 2001/07/27 05:23:29 jesse Exp $ # Copyright 1999-2001 Jesse Vincent package DBIx::SearchBuilder::Handle::Pg; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); use Want qw(howmany); =head1 NAME DBIx::SearchBuilder::Handle::Pg - A Postgres specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of Postgres. =head1 METHODS =cut =head2 Connect Connect takes a hashref and passes it off to SUPER::Connect; Forces the timezone to GMT it returns a database handle. =cut sub Connect { my $self = shift; my $rv = $self->SUPER::Connect(@_); $self->SimpleQuery("SET TIME ZONE 'GMT'"); $self->SimpleQuery("SET DATESTYLE TO 'ISO'"); $self->AutoCommit(1); return ($rv); } =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. In case of insert failure, returns a L object preloaded with error info. =cut sub Insert { my $self = shift; my $table = shift; my %args = (@_); my $sth = $self->SUPER::Insert( $table, %args ); return $sth unless $sth; if ( $args{'id'} || $args{'Id'} ) { $self->{'id'} = $args{'id'} || $args{'Id'}; return ( $self->{'id'} ); } my $sequence_name = $self->IdSequenceName($table); unless ($sequence_name) { return ($sequence_name) } # Class::ReturnValue my $seqsth = $self->dbh->prepare( qq{SELECT CURRVAL('} . $sequence_name . qq{')} ); $seqsth->execute; $self->{'id'} = $seqsth->fetchrow_array(); return ( $self->{'id'} ); } =head2 InsertQueryString Postgres sepcific overriding method for L. =cut sub InsertQueryString { my $self = shift; my ($query_string, @bind) = $self->SUPER::InsertQueryString( @_ ); $query_string =~ s/\(\s*\)\s+VALUES\s+\(\s*\)\s*$/DEFAULT VALUES/; return ($query_string, @bind); } =head2 IdSequenceName TABLE Takes a TABLE name and returns the name of the sequence of the primary key for that table. =cut sub IdSequenceName { my $self = shift; my $table = shift; return $self->{'_sequences'}{$table} if (exists $self->{'_sequences'}{$table}); #Lets get the id of that row we just inserted my $seq; my $colinfosth = $self->dbh->column_info( undef, undef, lc($table), '%' ); while ( my $foo = $colinfosth->fetchrow_hashref ) { # Regexp from DBIx::Class's Pg handle. Thanks to Marcus Ramberg if ( defined $foo->{'COLUMN_DEF'} && $foo->{'COLUMN_DEF'} =~ m!^nextval\(+'"?([^"']+)"?'(::(?:text|regclass)\))+!i ) { return $self->{'_sequences'}{$table} = $1; } } my $ret = Class::ReturnValue->new(); $ret->as_error( errno => '-1', message => "Found no sequence for $table", do_backtrace => undef ); return ( $ret->return_value ); } =head2 BinarySafeBLOBs Return undef, as no current version of postgres supports binary-safe blobs =cut sub BinarySafeBLOBs { my $self = shift; return(undef); } =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 "; $limit_clause .= $per_page; if ( $first && $first != 0 ) { $limit_clause .= " OFFSET $first"; } } $$statementref .= $limit_clause; } =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 sub _MakeClauseCaseInsensitive { my $self = shift; my $field = shift; my $operator = shift; my $value = shift; # we don't need to downcase numeric values and dates if ($value =~ /^$DBIx::SearchBuilder::Handle::RE_CASE_INSENSITIVE_CHARS+$/o) { return ( $field, $operator, $value); } if ( $operator =~ /LIKE/i ) { $operator =~ s/LIKE/ILIKE/ig; return ( $field, $operator, $value ); } elsif ( $operator =~ /=/ ) { if (howmany() >= 4) { return ( "LOWER($field)", $operator, $value, "LOWER(?)"); } # RT 3.0.x and earlier don't know how to cope with a "LOWER" function # on the value. they only expect field, operator, value. # else { return ( "LOWER($field)", $operator, lc($value)); } } else { $self->SUPER::_MakeClauseCaseInsensitive( $field, $operator, $value ); } } =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 $table = $sb->Table; return $self->SUPER::DistinctQuery( $statementref, $sb, @_ ) if $sb->_OrderClause !~ /(?{group_by} = [ map {+{FIELD => $_}} $self->Fields($table) ]; local $sb->{'order_by'} = [ map { ($_->{'ALIAS'}||'') ne "main" ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" } : $_ } @{$sb->{'order_by'}} ]; my $group = $sb->_GroupClause; my $order = $sb->_OrderClause; $$statementref = "SELECT main.* FROM $$statementref $group $order"; } =head2 SimpleDateTimeFunctions Returns hash reference with specific date time functions of this database for L. =cut sub SimpleDateTimeFunctions { my $self = shift; return $self->{'_simple_date_time_functions'} if $self->{'_simple_date_time_functions'}; my %res = %{ $self->SUPER::SimpleDateTimeFunctions(@_) }; s/SUBSTR\s*\(\s*\?/SUBSTR( CAST(? AS text)/ig for values %res; # everything else we should implement through date_trunc that # does SUBSTR(?, 1, X) on a date, but leaves trailing values # when we don't need them return $self->{'_simple_date_time_functions'} ||= { %res, datetime => '?', time => 'CAST(? AS time)', hour => 'EXTRACT(HOUR FROM ?)', date => 'CAST(? AS date)', daily => 'CAST(? AS date)', day => 'EXTRACT(DAY FROM ?)', month => 'EXTRACT(MONTH FROM ?)', annually => 'EXTRACT(YEAR FROM ?)', year => 'EXTRACT(YEAR FROM ?)', dayofweek => "EXTRACT(DOW FROM ?)", # 0-6, 0 - Sunday dayofyear => "EXTRACT(DOY FROM ?)", # 1-366 # 1-53, 1st week January 4, week starts on Monay weekofyear => "EXTRACT(WEEK FROM ?)", }; } =head2 ConvertTimezoneFunction Custom implementation of L. In Pg time and timestamp data types may be "with time zone" or "without time zone". So if Field argument is timestamp "with time zone" then From argument is not required and is useless. Otherwise From argument identifies time zone of the Field argument that is "without time zone". For consistency with other DBs use timestamp columns without time zones and provide From argument. =cut sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'} unless $args{From} && $args{'To'}; return $args{'Field'} if lc $args{From} eq lc $args{'To'}; my $dbh = $self->dbh; my $res = $args{'Field'}; $res = "TIMEZONE($_, $res)" foreach map $dbh->quote( $_ ), grep $_, @args{'From', 'To'}; return $res; } sub _DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); return "(EXTRACT(EPOCH FROM $args{'To'}) - EXTRACT(EPOCH FROM $args{'From'}))"; } sub HasSupportForNullsOrder { return 1; } 1; __END__ =head1 SEE ALSO DBIx::SearchBuilder, DBIx::SearchBuilder::Handle =cut DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Handle/mysqlPP.pm0000644000175000017500000000071112071136620022330 0ustar tomtompackage DBIx::SearchBuilder::Handle::mysqlPP; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle::mysql); 1; __END__ =head1 NAME DBIx::SearchBuilder::Handle::mysqlPP - A mysql specific Handle object =head1 DESCRIPTION A Handle subclass for the "pure perl" mysql database driver. This is currently identical to the DBIx::SearchBuilder::Handle::mysql class. =head1 AUTHOR =head1 SEE ALSO DBIx::SearchBuilder::Handle::mysql =cut DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Handle/Oracle.pm0000755000175000017500000002705012143046620022140 0ustar tomtom# $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/Oracle.pm,v 1.14 2002/01/28 06:11:37 jesse Exp $ package DBIx::SearchBuilder::Handle::Oracle; use strict; use warnings; use base qw/DBIx::SearchBuilder::Handle/; use DBD::Oracle qw(:ora_types ORA_OCI); =head1 NAME DBIx::SearchBuilder::Handle::Oracle - An oracle specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of Oracle. =head1 METHODS =cut =head2 Connect PARAMHASH: Driver, Database, Host, User, Password Takes a paramhash and connects to your DBI datasource. =cut sub Connect { my $self = shift; my %args = ( Driver => undef, Database => undef, User => undef, Password => undef, SID => undef, Host => undef, @_); my $rv = $self->SUPER::Connect(%args); $self->dbh->{LongTruncOk}=1; $self->dbh->{LongReadLen}=8000; foreach my $setting (qw(DATE TIMESTAMP TIMESTAMP_TZ)) { $self->SimpleQuery( "ALTER SESSION set NLS_${setting}_FORMAT = 'YYYY-MM-DD HH24:MI:SS'" ); } return ($rv); } =head2 BuildDSN Customized version of L method. Takes additional argument SID. Database argument used unless SID provided. Two forms of DSN are generated depending on whether Host defined or not: dbi:Oracle:sid=;host=...[;port=...] dbi:Oracle: Read details in documentation for L module. =cut sub BuildDSN { my $self = shift; my %args = ( Driver => undef, Database => undef, Host => undef, Port => undef, SID => undef, @_ ); $args{'Driver'} ||= 'Oracle'; # read DBD::Oracle for details, but basicly it supports # either 'dbi:Oracle:SID' or 'dbi:Oracle:sid=SID;host=...;[port=...;]' # and tests shows that 'dbi:Oracle:SID' != 'dbi:Oracle:sid=SID' $args{'SID'} ||= $args{'Database'}; my $dsn = "dbi:$args{'Driver'}:"; if ( $args{'Host'} ) { $dsn .= "sid=$args{'SID'}" if $args{'SID'}; $dsn .= ";host=$args{'Host'}"; $dsn .= ";port=$args{'Port'}" if $args{'Port'}; } else { $dsn .= $args{'SID'} if $args{'SID'}; $dsn .= ";port=$args{'Port'}" if $args{'Port'}; } return $self->{'dsn'} = $dsn; } =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. =cut sub Insert { my $self = shift; my $table = shift; my ($sth); # Oracle Hack to replace non-supported mysql_rowid call my %attribs = @_; my ($unique_id, $QueryString); if ($attribs{'Id'} || $attribs{'id'}) { $unique_id = ($attribs{'Id'} ? $attribs{'Id'} : $attribs{'id'} ); } else { $QueryString = "SELECT ".$table."_seq.nextval FROM DUAL"; $sth = $self->SimpleQuery($QueryString); if (!$sth) { if ($main::debug) { die "Error with $QueryString"; } else { return (undef); } } #needs error checking my @row = $sth->fetchrow_array; $unique_id = $row[0]; } #TODO: don't hardcode this to id pull it from somewhere else #call super::Insert with the new column id. $attribs{'id'} = $unique_id; delete $attribs{'Id'}; $sth = $self->SUPER::Insert( $table, %attribs); unless ($sth) { if ($main::debug) { die "Error with $QueryString: ". $self->dbh->errstr; } else { return (undef); } } $self->{'id'} = $unique_id; return( $self->{'id'}); #Add Succeded. return the id } =head2 InsertFromSelect Customization of L. Unlike other DBs Oracle needs: =over 4 =item * id generated from sequences for every new record. =item * query wrapping in parens. =back B that on Oracle there is a limitation on the query. Every column in the result should have unique name or alias, for example the following query would generate "ORA-00918: column ambiguously defined" error: SELECT g.id, u.id FROM ... Solve with aliases: SELECT g.id AS group_id, u.id AS user_id FROM ... =cut sub InsertFromSelect { my ($self, $table, $columns, $query, @binds) = @_; if ( $columns && !grep lc($_) eq 'id', @$columns ) { unshift @$columns, 'id'; $query = "SELECT ${table}_seq.nextval, insert_from.* FROM ($query) insert_from"; } return $self->SUPER::InsertFromSelect( $table, $columns, "($query)", @binds); } =head2 KnowsBLOBs Returns 1 if the current database supports inserts of BLOBs automatically. Returns undef if the current database must be informed of BLOBs for inserts. =cut sub KnowsBLOBs { my $self = shift; return(undef); } =head2 BLOBParams FIELD_NAME FIELD_TYPE Returns a hash ref for the bind_param call to identify BLOB types used by the current database for a particular column type. The current Oracle implementation only supports ORA_CLOB types (112). =cut sub BLOBParams { my $self = shift; my $field = shift; #my $type = shift; # Don't assign to key 'value' as it is defined later. return ( { ora_field => $field, ora_type => ORA_CLOB, }); } =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; # Transform an SQL query from: # # SELECT main.* # FROM Tickets main # WHERE ((main.EffectiveId = main.id)) # AND ((main.Type = 'ticket')) # AND ( ( (main.Status = 'new')OR(main.Status = 'open') ) # AND ( (main.Queue = '1') ) ) # # to: # # SELECT * FROM ( # SELECT limitquery.*,rownum limitrownum FROM ( # SELECT main.* # FROM Tickets main # WHERE ((main.EffectiveId = main.id)) # AND ((main.Type = 'ticket')) # AND ( ( (main.Status = 'new')OR(main.Status = 'open') ) # AND ( (main.Queue = '1') ) ) # ) limitquery WHERE rownum <= 50 # ) WHERE limitrownum >= 1 # if ($per_page) { # Oracle orders from 1 not zero $first++; # Make current query a sub select $$statementref = "SELECT * FROM ( SELECT limitquery.*,rownum limitrownum FROM ( $$statementref ) limitquery WHERE rownum <= " . ($first + $per_page - 1) . " ) WHERE limitrownum >= " . $first; } } =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 $table = $sb->Table; if ($sb->_OrderClause =~ /(?{group_by} = [@{$sb->{group_by} || []}, {FIELD => 'id'}]; local $sb->{'order_by'} = [ map { ($_->{'ALIAS'}||'') ne "main" ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" } : $_ } @{$sb->{'order_by'}} ]; my $group = $sb->_GroupClause; my $order = $sb->_OrderClause; $$statementref = "SELECT main.* FROM ( SELECT main.id, row_number() over( $order ) sortorder FROM $$statementref $group ) distinctquery, $table main WHERE (main.id = distinctquery.id) ORDER BY distinctquery.sortorder"; } else { # Wrapp select query in a subselect as Oracle doesn't allow # DISTINCT against CLOB/BLOB column types. $$statementref = "SELECT main.* FROM ( SELECT DISTINCT main.id FROM $$statementref ) distinctquery, $table main WHERE (main.id = distinctquery.id) "; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } } =head2 BinarySafeBLOBs Return undef, as Oracle doesn't support binary-safe CLOBS =cut sub BinarySafeBLOBs { my $self = shift; return(undef); } =head2 DatabaseVersion Returns value of ORA_OCI constant, see L. =cut sub DatabaseVersion { return ''. ORA_OCI; } sub Fields { my $self = shift; my $table = shift; my $cache = \%DBIx::SearchBuilder::Handle::FIELDS_IN_TABLE; unless ( $cache->{ lc $table } ) { # uc(table) required as oracle stores UC names in information tables # and lookup clauses are case sensetive my $sth = $self->dbh->column_info( undef, undef, uc($table), '%' ) or return (); my $info = $sth->fetchall_arrayref({}); # TODO: not sure why results are lower case, probably NAME_ls affects it # we should check it out at some point foreach my $e ( sort {$a->{'ordinal_position'} <=> $b->{'ordinal_position'}} @$info ) { push @{ $cache->{ lc $e->{'table_name'} } ||= [] }, lc $e->{'column_name'}; } } return @{ $cache->{ lc $table } || [] }; } =head2 SimpleDateTimeFunctions Returns hash reference with specific date time functions of this database for L. =cut # http://download.oracle.com/docs/cd/B14117_01/server.101/b10749/ch4datetime.htm sub SimpleDateTimeFunctions { my $self = shift; return $self->{'_simple_date_time_functions'} if $self->{'_simple_date_time_functions'}; my %res = %{ $self->SUPER::SimpleDateTimeFunctions(@_) }; return $self->{'_simple_date_time_functions'} ||= { %res, datetime => "?", time => "TO_CHAR(?, 'HH24:MI:SS')", hourly => "TO_CHAR(?, 'YYYY-MM-DD HH24')", hour => "TO_CHAR(?, 'HH24')", date => "TO_CHAR(?, 'YYYY-MM-DD')", daily => "TO_CHAR(?, 'YYYY-MM-DD')", day => "TO_CHAR(?, 'DD')", dayofmonth => "TO_CHAR(?, 'DD')", monthly => "TO_CHAR(?, 'YYYY-MM')", month => "TO_CHAR(?, 'MM')", annually => "TO_CHAR(?, 'YYYY')", year => "TO_CHAR(?, 'YYYY')", dayofweek => "TO_CHAR(?, 'D') - 1", # 1-7, 1 - Sunday dayofyear => "TO_CHAR(?, 'DDD')", # 1-366 # no idea about props weekofyear => "TO_CHAR(?, 'WW')", }; } =head2 ConvertTimezoneFunction Custom implementation of L. Use the following query to get list of timezones: SELECT tzname FROM v$timezone_names; Read Oracle's docs about timezone files: http://download.oracle.com/docs/cd/B14117_01/server.101/b10749/ch4datetime.htm#i1006667 =cut sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'} unless $args{From} && $args{'To'}; return $args{'Field'} if lc $args{From} eq lc $args{'To'}; my $dbh = $self->dbh; $_ = $dbh->quote( $_ ) foreach @args{'From', 'To'}; return "FROM_TZ( CAST ($args{'Field'} AS TIMESTAMP), $args{'From'}) AT TIME ZONE $args{'To'}"; } sub _DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); return "ROUND(( CAST( $args{'To'} AS DATE ) - CAST( $args{'From'} AS DATE ) ) * 86400)"; } sub HasSupportForNullsOrder { return 1; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO perl(1), DBIx::SearchBuilder =cut DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Handle/Sybase.pm0000644000175000017500000000575212071136620022163 0ustar tomtom# $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/Sybase.pm,v 1.8 2001/10/12 05:27:05 jesse Exp $ package DBIx::SearchBuilder::Handle::Sybase; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::Sybase -- a Sybase specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of Sybase. =head1 METHODS =cut =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. If the insert succeeds, returns the id of the insert, otherwise, returns a Class::ReturnValue object with the error reported. =cut sub Insert { my $self = shift; my $table = shift; my %pairs = @_; my $sth = $self->SUPER::Insert( $table, %pairs ); if ( !$sth ) { return ($sth); } # Can't select identity column if we're inserting the id by hand. unless ($pairs{'id'}) { my @row = $self->FetchResult('SELECT @@identity'); # TODO: Propagate Class::ReturnValue up here. unless ( $row[0] ) { return (undef); } $self->{'id'} = $row[0]; } return ( $self->{'id'} ); } =head2 DatabaseVersion return the database version, trimming off any -foo identifier =cut sub DatabaseVersion { my $self = shift; my $v = $self->SUPER::DatabaseVersion(); $v =~ s/\-(.*)$//; return ($v); } =head2 CaseSensitive Returns undef, since Sybase's searches are not case sensitive by default =cut sub CaseSensitive { my $self = shift; return(1); } sub ApplyLimits { my $self = shift; my $statementref = shift; my $per_page = shift; my $first = shift; } =head2 DistinctQuery STATEMENTREFtakes 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 $table = $sb->Table; if ($sb->_OrderClause =~ /(?_GroupClause; $$statementref .= $sb->_OrderClause; } =head2 BinarySafeBLOBs Return undef, as Oracle doesn't support binary-safe CLOBS =cut sub BinarySafeBLOBs { my $self = shift; return(undef); } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO DBIx::SearchBuilder, DBIx::SearchBuilder::Handle =cut DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Handle/ODBC.pm0000644000175000017500000000334412071136620021437 0ustar tomtom# $Header: /home/jesse/DBIx-SearchBuilder/history/SearchBuilder/Handle/ODBC.pm,v 1.8 2001/10/12 05:27:05 jesse Exp $ package DBIx::SearchBuilder::Handle::ODBC; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::ODBC - An ODBC specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of ODBC. =head1 METHODS =cut =head2 CaseSensitive Returns a false value. =cut sub CaseSensitive { my $self = shift; return (undef); } =head2 BuildDSN =cut sub BuildDSN { my $self = shift; my %args = ( Driver => undef, Database => undef, Host => undef, Port => undef, @_ ); my $dsn = "dbi:$args{'Driver'}:$args{'Database'}"; $dsn .= ";host=$args{'Host'}" if (defined $args{'Host'} && $args{'Host'}); $dsn .= ";port=$args{'Port'}" if (defined $args{'Port'} && $args{'Port'}); $self->{'dsn'} = $dsn; } =head2 ApplyLimits =cut sub ApplyLimits { my $self = shift; my $statementref = shift; my $per_page = shift or return; my $first = shift; my $limit_clause = " TOP $per_page"; $limit_clause .= " OFFSET $first" if $first; $$statementref =~ s/SELECT\b/SELECT $limit_clause/; } =head2 DistinctQuery =cut sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; $$statementref = "SELECT main.* FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } sub Encoding { } 1; __END__ =head1 AUTHOR Autrijus Tang =head1 SEE ALSO DBIx::SearchBuilder, DBIx::SearchBuilder::Handle =cut DBIx-SearchBuilder-1.65/lib/DBIx/SearchBuilder/Handle/SQLite.pm0000644000175000017500000001247112143046615022076 0ustar tomtom package DBIx::SearchBuilder::Handle::SQLite; use strict; use warnings; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::SQLite -- A SQLite specific Handle object =head1 SYNOPSIS =head1 DESCRIPTION This module provides a subclass of DBIx::SearchBuilder::Handle that compensates for some of the idiosyncrasies of SQLite. =head1 METHODS =head2 DatabaseVersion Returns the version of the SQLite library which is used, e.g., "2.8.0". SQLite can only return short variant. =cut sub DatabaseVersion { my $self = shift; return '' unless $self->dbh; return $self->dbh->{sqlite_version} || ''; } =head2 Insert Takes a table name as the first argument and assumes that the rest of the arguments are an array of key-value pairs to be inserted. If the insert succeeds, returns the id of the insert, otherwise, returns a Class::ReturnValue object with the error reported. =cut sub _last_insert_rowid { my $self = shift; my $table = shift; return $self->dbh->func('last_insert_rowid'); # XXX: this is workaround nesty sqlite problem that # last_insert_rowid in transaction is inaccurrate with multiple # inserts. return $self->dbh->func('last_insert_rowid') unless $self->TransactionDepth; # XXX: is the name of the column always id ? my $ret = $self->FetchResult("select max(id) from $table"); return $ret; } sub Insert { my $self = shift; my $table = shift; my %args = ( id => undef, @_); # We really don't want an empty id my $sth = $self->SUPER::Insert($table, %args); return unless $sth; # If we have set an id, then we want to use that, otherwise, we want to lookup the last _new_ rowid $self->{'id'}= $args{'id'} || $self->_last_insert_rowid($table); warn "$self no row id returned on row creation" unless ($self->{'id'}); return( $self->{'id'}); #Add Succeded. return the id } =head2 CaseSensitive Returns undef, since SQLite's searches are not case sensitive by default =cut sub CaseSensitive { my $self = shift; return(1); } sub BinarySafeBLOBs { return undef; } sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; return $self->SUPER::DistinctQuery( $statementref, $sb, @_ ) if $sb->_OrderClause !~ /(?{'group_by'} = [{FIELD => 'id'}]; local $sb->{'order_by'} = [ map { ($_->{'ALIAS'}||'') ne "main" ? { %{$_}, FIELD => ((($_->{'ORDER'}||'') =~ /^des/i)?'MAX':'MIN') ."(".$_->{FIELD}.")" } : $_ } @{$sb->{'order_by'}} ]; $$statementref = "SELECT main.* FROM $$statementref"; $$statementref .= $sb->_GroupClause; $$statementref .= $sb->_OrderClause; } =head2 DistinctCount STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result count =cut sub DistinctCount { my $self = shift; my $statementref = shift; $$statementref = "SELECT count(*) FROM (SELECT DISTINCT main.id FROM $$statementref )"; } sub Fields { my $self = shift; my $table = shift; my $cache = \%DBIx::SearchBuilder::Handle::FIELDS_IN_TABLE; unless ( $cache->{lc $table} ) { my $info = $self->dbh->selectall_arrayref("PRAGMA table_info('$table')") or return (); foreach my $e ( @$info ) { push @{ $cache->{ lc $table } ||= [] }, lc $e->[1]; } } return @{ $cache->{ lc $table } || [] }; } =head2 SimpleDateTimeFunctions Returns hash reference with specific date time functions of this database for L. =cut sub SimpleDateTimeFunctions { my $self = shift; return $self->{'_simple_date_time_functions'} ||= { %{ $self->SUPER::SimpleDateTimeFunctions(@_) }, datetime => 'datetime(?)', time => 'time(?)', hourly => "strftime('%Y-%m-%d %H', ?)", hour => "strftime('%H', ?)", date => 'date(?)', daily => 'date(?)', day => "strftime('%d', ?)", dayofmonth => "strftime('%d', ?)", monthly => "strftime('%Y-%m', ?)", month => "strftime('%m', ?)", annually => "strftime('%Y', ?)", year => "strftime('%Y', ?)", dayofweek => "strftime('%w', ?)", dayofyear => "strftime('%j', ?)", weekofyear => "strftime('%W', ?)", }; } sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'} unless $args{From} && $args{'To'}; return $args{'Field'} if lc $args{From} eq lc $args{'To'}; my $res; if ( lc($args{'To'}||'') eq 'utc' ) { $res = "datetime($args{'Field'}, 'utc')"; } elsif ( lc($args{'From'}||'') eq 'utc' ) { $res = "datetime($args{'Field'}, 'localtime')"; } else { warn "SQLite only supports TZ convesion from UTC or to UTC"; $res = $args{'Field'}; } return $res; } sub _DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); return "strftime('%s',$args{'To'}) - strftime('%s',$args{'From'})"; } 1; __END__ =head1 AUTHOR Jesse Vincent, jesse@fsck.com =head1 SEE ALSO perl(1), DBIx::SearchBuilder =cut DBIx-SearchBuilder-1.65/ex/0000700000175000017500000000000012165133403013525 5ustar tomtomDBIx-SearchBuilder-1.65/ex/Example/0000700000175000017500000000000012165133403015120 5ustar tomtomDBIx-SearchBuilder-1.65/ex/Example/Model/0000700000175000017500000000000012165133403016160 5ustar tomtomDBIx-SearchBuilder-1.65/ex/Example/Model/Address.pm0000644000175000017500000000053512023465411020120 0ustar tomtompackage 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.65/ex/Example/Model/Employee.pm0000644000175000017500000000033712023465411020312 0ustar tomtompackage 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.65/ex/create_tables.pl0000644000175000017500000000323112023465411016670 0ustar tomtom#!/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.65/.gitignore0000644000175000017500000000013012104270376015111 0ustar tomtomMakefile Makefile.bak Makefile.old MANIFEST.old MANIFEST.bak pm_to_blib blib/ MYMETA.* DBIx-SearchBuilder-1.65/SIGNATURE0000644000175000017500000001201512165133403014406 0ustar tomtomThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.69. 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 1a1bc4ff5520786b82ccc537ec795ca28088cad2 Changes SHA1 f9526289f15de085cbe55ce253b5964856fc3092 MANIFEST SHA1 eddfdceb91ce00190de629547b994cfe467a857d META.yml SHA1 879332930c43934dc2ead7ad8668c0ab190c9f29 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 06c410f05488c1612ed66b06d3a86b2580581e4a inc/Module/AutoInstall.pm SHA1 8a924add836b60fb23b25c8506d45945e02f42f4 inc/Module/Install.pm SHA1 61ab1dd37e33ddbe155907ce51df8a3e56ac8bbf inc/Module/Install/AutoInstall.pm SHA1 2d0fad3bf255f8c1e7e1e34eafccc4f595603ddc inc/Module/Install/Base.pm SHA1 f0e01fff7d73cd145fbf22331579918d4628ddb0 inc/Module/Install/Can.pm SHA1 7328966e4fda0c8451a6d3850704da0b84ac1540 inc/Module/Install/Fetch.pm SHA1 66d3d335a03492583a3be121a7d888f63f08412c inc/Module/Install/Include.pm SHA1 b62ca5e2d58fa66766ccf4d64574f9e1a2250b34 inc/Module/Install/Makefile.pm SHA1 1aa925be410bb3bfcd84a16985921f66073cc1d2 inc/Module/Install/Metadata.pm SHA1 e4196994fa75e98bdfa2be0bdeeffef66de88171 inc/Module/Install/Win32.pm SHA1 c3a6d0d5b84feb3280622e9599e86247d58b0d18 inc/Module/Install/WriteAll.pm SHA1 7e63abf9aab1b74823a963acdb1ca3dffe2c3fc8 lib/DBIx/SearchBuilder.pm SHA1 6a7c90aeae63ba9584ac7f15fb3340a41c5d4325 lib/DBIx/SearchBuilder/Handle.pm SHA1 55d337e6dd1ab5aecc39d2ae491bffb12e9ca449 lib/DBIx/SearchBuilder/Handle/Informix.pm SHA1 4efdcaefa5f94d994b052d1b343d2f5164ef4b52 lib/DBIx/SearchBuilder/Handle/ODBC.pm SHA1 5effbaa557cce330503f117dd6c02f5a8fc1b01e lib/DBIx/SearchBuilder/Handle/Oracle.pm SHA1 7926d63560821a7bc8c9634bc6135833fe741261 lib/DBIx/SearchBuilder/Handle/Pg.pm SHA1 ebeef91ec5d215b02aa10d8e990a92f4d38bbe52 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 145046df9fcea187d59493a02c62c578fcf75599 lib/DBIx/SearchBuilder/Record/Cachable.pm SHA1 a15065e472797e2bfe8149f04d3bdc58f67a7a6d lib/DBIx/SearchBuilder/SchemaGenerator.pm SHA1 f59ad14464f1520aa4f9dacdf437047081a94741 lib/DBIx/SearchBuilder/Union.pm SHA1 1eb4e838ff1d8d927bfe177bf578df246802b03d lib/DBIx/SearchBuilder/Unique.pm SHA1 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----- Version: GnuPG v1.4.11 (GNU/Linux) iD8DBQFR1LcDHdv9ZfNcOAcRAlKFAJ9LpqrcM54lG4khRwxWE+PqxtkRJgCeOrsY IBOjrltkmFglYUuoZnXkLB0= =rgT2 -----END PGP SIGNATURE----- DBIx-SearchBuilder-1.65/Makefile.PL0000755000175000017500000000134712131411261015077 0ustar tomtomuse inc::Module::Install; name ('DBIx-SearchBuilder'); license ('perl'); author ('Jesse Vincent '); 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.65/inc/0000700000175000017500000000000012165133403013662 5ustar tomtomDBIx-SearchBuilder-1.65/inc/Module/0000700000175000017500000000000012165133403015107 5ustar tomtomDBIx-SearchBuilder-1.65/inc/Module/AutoInstall.pm0000644000175000017500000006216212165133377017737 0ustar tomtom#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # 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::cwd(); $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 combatability 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 ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @installed; @installed = (); } 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} = $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::cwd() ); 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 1193 DBIx-SearchBuilder-1.65/inc/Module/Install.pm0000644000175000017500000003013512165133376017100 0ustar tomtom#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.005; 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.06'; # 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::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } 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::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } 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 //, $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]): $!"; 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]): $!"; 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]): $!"; 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]): $!"; 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.65/inc/Module/Install/0000700000175000017500000000000012165133403016515 5ustar tomtomDBIx-SearchBuilder-1.65/inc/Module/Install/Base.pm0000644000175000017500000000214712165133377017755 0ustar tomtom#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # 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.65/inc/Module/Install/Can.pm0000644000175000017500000000615712165133400017574 0ustar tomtom#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.06'; @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.65/inc/Module/Install/Fetch.pm0000644000175000017500000000462712165133400020124 0ustar tomtom#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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.65/inc/Module/Install/Makefile.pm0000644000175000017500000002743712165133377020631 0ustar tomtom#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.06'; @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-seperated 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.65/inc/Module/Install/AutoInstall.pm0000644000175000017500000000416212165133377021341 0ustar tomtom#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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.65/inc/Module/Install/Win32.pm0000644000175000017500000000340312165133400017764 0ustar tomtom#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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.65/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612165133400020615 0ustar tomtom#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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.65/inc/Module/Install/Metadata.pm0000644000175000017500000004327712165133377020634 0ustar tomtom#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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 hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; DBIx-SearchBuilder-1.65/inc/Module/Install/Include.pm0000644000175000017500000000101512165133377020457 0ustar tomtom#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @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.65/ROADMAP0000644000175000017500000000522712023465411014137 0ustar tomtomThings 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.65/t/0000700000175000017500000000000012165133403013354 5ustar tomtomDBIx-SearchBuilder-1.65/t/testmodels.pl0000644000175000017500000000131412023465411016105 0ustar tomtompackage 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.65/t/02searches_joins.t0000644000175000017500000003423212154156652016731 0ustar tomtom#!/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.65/t/02records_dt_interval.t0000644000175000017500000000772012164604751017767 0ustar tomtom#!/usr/bin/perl -w BEGIN { $ENV{'TZ'} = 'Europe/Moscow' }; use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 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.65/t/03transactions.t0000644000175000017500000001512012143046620016425 0ustar tomtom#!/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 { < 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.65/t/20set_edge_cases.t0000644000175000017500000000715712143046615016670 0ustar tomtom#!/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 { < 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 { <. 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.65/t/02distinct_values.t0000644000175000017500000000745312071462042017126 0ustar tomtom#!/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.65/t/02searches_function.t0000644000175000017500000002027312143046615017427 0ustar tomtom#!/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.65/t/01nocap_api.t0000644000175000017500000000171112023465411015645 0ustar tomtom#!/usr/bin/perl -w use strict; use Test::More; BEGIN { require "t/utils.pl" } use vars qw(@SPEC_METHODS @MODULES); my @SPEC_METHODS = qw(AUTOLOAD DESTROY CLONE); my @MODULES = qw(DBIx::SearchBuilder DBIx::SearchBuilder::Record); if( not eval { require Devel::Symdump } ) { plan skip_all => '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.65/t/03compatibility.t0000644000175000017500000000137212104270376016576 0ustar tomtom#!/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.65/t/03rebless.t0000644000175000017500000000137312023465411015361 0ustar tomtom#!/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.65/t/02records_integers.t0000644000175000017500000001246712131412144017263 0ustar tomtom#!/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 { < 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.65/t/02records_object.t0000644000175000017500000000741612071136620016714 0ustar tomtom#!/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.65/t/01basics.t0000644000175000017500000000074612023465411015167 0ustar tomtom#!/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.65/t/02order_outer.t0000644000175000017500000001273512023465411016256 0ustar tomtom#!/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.65/t/pod.t0000644000175000017500000000020111433314013014321 0ustar tomtomuse 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.65/t/02null_order.t0000644000175000017500000001010412143046620016056 0ustar tomtom#!/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 ); 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.65/t/03cud_from_select.t0000644000175000017500000001773312105306532017065 0ustar tomtom#!/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.65/t/00.load.t0000644000175000017500000000144112071136620014710 0ustar tomtomuse 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.65/t/01searches.t0000644000175000017500000005123412145022750015516 0ustar tomtom#!/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.65/t/11schema_records.t0000644000175000017500000001522212023465411016700 0ustar tomtom#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 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.65/t/03versions.t0000644000175000017500000000210412023465411015563 0ustar tomtom#!/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.65/t/02records_cachable.t0000644000175000017500000000654712023465411017174 0ustar tomtom#!/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 { <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 Thomas Sibley: * 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 Wed Apr 17 18:47:31 MSK 2013 * _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 Wed Mar 27 13:02:35 PDT 2013 * 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 Fri Sep 14 2012 01:19:38 GMT+0400 (MSK) * joins_are_distinct hint to indicate that distinct is not required for the current set of joins. 1.62 Mon Mar 26 09:31:05 UTC 2012 * Bind values were ignored in SimpleUpdateFromSelect 1.61 Fri Sep 16 15:47:50 MSD 2011 * New methods in Handle for mass changes from select statements: InsertFromSelect, DeleteFromSelect and SimpleUpdateFromSelect * New methods in Handle for generation of date time related SQL 1.60 Thu Sep 15 01:01:15 MSD 2011 * custom BuildDSN for Oracle ** Database is treated as SID if SID is not provided ** Build 'dbi:Oracle:' 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 Fri Nov 19 13:45:01 MSK 2010 * DBIx::SearchBuilder->DistinctFieldValues method 1.58 Wed Oct 20 02:17:37 MSD 2010 * SIGNATURE fix * delete obsolete cvs metadata from a module 1.57 Mon Sep 4 21:21:57 UTC 2010 * 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 Fri Jul 17 02:05:32 MSD 2009 * 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 Thu May 7 19:44:47 MSD 2009 * 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 Wed Jul 9 09:34:25 EDT 2008 * 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 Tue Apr 2 03:06:56 UTC 2008 * Fix mysql version check in DistinctQuery function * Fix order by outer column on Oracle * Improve tests 1.52 Tue Apr 1 00:48:56 UTC 2008 * Fix order by outer column on SQLite, mysql, adjust Pg. Add test that cover this. 1.51 Tue Jan 15 22:53:56 UTC 2008 * Fix CountAll method when paging is enabled and data is in memory already 1.50 Fri Nov 23 23:24:00 UTC 2007 * 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 Sat Jul 7 18:45:41 EDT 2007 * Fix a CPAN signature issue 1.48 Sun Mar 11 05:24:40 UTC 2007 * Fix a problem when left joins optimizer fails to calculate a boolean expression because of lower case aggregators. 1.47 Sun Mar 4 03:30:00 UTC 2007 * 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 Sun Feb 25 19:04:00 UTC 2007 * 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 Tue Sep 26 11:08:20 EDT 2006 * Postgres fixes: ** fix "$rec->Create();" ** fix "$rec->Create( IntegerColumn => '' );" ** fix "$rec->SetIntegerColumn( '' );" ** add test * Cache changes ** cleanup ::Record::Cachable ** use cache in: $a->LoadByCols(...); $b->LoadById( $a->id ); ** add cache tests 1.44 * DBIx::SearchBuilder::Handle::DatabaseVersion enhancements 1.43 Wed Apr 12 13:59:58 EDT 2006 * Fix to the sequence compatibility fixes. For backwards compatibility. 1.42 Mon Apr 10 11:27:39 EDT 2006 * Signatures fixed 1.41 Mon Apr 10 11:26:19 EDT 2006 * PG 8.1 sequence compatibility fixes from Daniel Tabuenca 1.40 not released yet * 'NOT STARTSWITH' and 'NOT ENDSWITH' 1.39 Thu Feb 16 16:27:42 PST 2006 * Allow ORs on left joins 1.38 Thu Dec 29 03:17:54 EST 2005 * Released 1.37 dev series 1.37_01 Thu Dec 8 15:56:50 EST 2005 * Switched Postgres sequence lookups to use CURRVAL, rather than OIDs 1.36 Fri Dec 2 18:04:21 EST 2005 * Change to how we resolve virtual columns to deal with a "no such attribute" bug in RT 1.35 Wed Nov 2 22:36:02 EST 2005 * Doc fixes and OrderBy cleanup from ruslan 1.34 Wed Nov 2 22:26:15 EST 2005 * Clone support from Ruslan 1.33 Thu Sep 22 14:27:46 EDT 2005 * Better SQL statement logging from alex 1.32 Thu Sep 1 06:52:42 EDT 2005 * DBD::SQLite is necessary for the test suite to run correctl 1.31 Fri Jul 29 12:47:25 EDT 2005 * Updated MANIFEST to fix a build issue - Thanks to Andy Lester and David Glasser 1.30 Thu Jul 28 10:17:27 EDT 2005 * Removed {{{ and }}} fold markers. Patch from Ruslan 1.30_03 Thu Jun 9 01:35:49 EDT 2005 * 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. Fixes from Ruslan: * 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 Sun May 22 15:21:19 EDT 2005 - 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 Mon May 16 21:37:03 BST 2005 - Patches from Ruslan to switch to using 'capitalization.pm' for our regular_case subroutine aliases 1.27 Sun May 8 22:49:30 EDT 2005 - 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 Sun Apr 17 19:22:23 EDT 2005 - Added support for expression based left joins 1.25 Sat Apr 9 12:33:30 EDT 2005 - Backed out a change introduced in 1.23 that caused table and column names to be quoted, causing Postgres to flip out. 1.24 Wed Apr 6 22:54:37 EDT 2005 - 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 Mon Jan 24 07:42:46 EST 2005 - Require encode since we require encode. 1.21 - 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 Tue Jan 18 08:24:15 EST 2005 - Minor test suite fixes from Ruslan. 1.19 Sat Jan 8 18:22:59 EST 2005 - 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 Thu Dec 9 23:49:39 EST 2004 - 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 Sat Nov 27 13:09:56 EST 2004 - 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 - Identical to 1.10_05 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 Mon Aug 30 17:33:18 EDT 2004 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. Stack: [/usr/local/share/perl/5.8.3/DBIx/SearchBuilder/Handle.pm:965] [/usr/local/share/perl/5.8.3/DBIx/SearchBuilder.pm:326] [/usr/local/share/perl/5.8.3/DBIx/SearchBuilder.pm:119] [/usr/local/share/perl/5.8.3/DBIx/SearchBuilder.pm:410] 1.10_03 Mon Aug 30 14:31:10 EDT 2004 - Cache Sanity fixes from Autrijus Tang 1.10_02 Thu Aug 26 13:31:13 EDT 2004 1.10_01 Thu Aug 26 00:08:31 EDT 2004 - Reimplemented DBIx::SearchBuilder:::Record::Cachable to use Cache::Simple::TimedExpiry. This should make it faster and more memory efficient. 1.02_03 Thu Jul 22 13:29:17 EDT 2004 - Additional bullet proofing for joins. Now we default to ALIAS1 being "main" (cubic@acronis.ru) 1.02_02 Tue Jul 20 13:06:06 EDT 2004 - Fixed a join bug that mostly manifests as a 'Dependency chain' error on RT2. 1.02_01 Wed Jul 7 12:28:08 EDT 2004 - magic _Object instantiation from cubic@acronis.ru - make SB::_Handle settable directly (cubic@acronis.ru) - document the above 1.01 Sun Jun 27 23:35:46 EDT 2004 - 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 - Releasing 0.96_01 as usable 0.96_01 - Fix a couple of spurious warnings in Record::Cachable Records loaded from multiple-record searches were never cached correctly 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 Sept 4, 2003 - Fixed a bug that caused certain types of pre-canned table aliases to fail to work on join 0.90 Aug 8, 2003 - Disable Class::ReturnValue's stack trace feature as it interacted poorly with a stack containing lots of data 0.89_02 July 19, 2003 - Patch from Grant DeGraw to allow ordering by multiple columns. 0.89_01 July 18 2003 - Patch from Brook for: - better oracle support - remove "SELECT DISTINCT" when it's not necessary 0.88 June 23 2003 - More correct generation of "Distinct" keyword on counts for queries with left joins 0.87 June 16 2003 - Changed DBIx::SB::Record::Cachable to expire cached object when a "deeper" method call changes their values 0.86 June 7 2003 - Doing conditional connections was failing on postgres, because the handle was defined, but not connected 0.85 June 7 2003 - Stan's destroy fix was actually badly breaking RT - It's now an optional parameter. 0.84 June 4 2003 - Bumped the version for release 0.83_05 June 2 2003 - Provide support for blowing away nested transactions that aren't yet committed. 0.83_04 June 2 2003 - Fixed how values of returned hashes are downcased. - Should be a minor perf improvement 0.83_03 May 30 2003 - Moved Stan's destryo fix to the right file 0.83_02 May 27 2003 - Better oracle support for unique ids on indexes from Brook 0.83_01 May 27 2003 - Stan's DESTROY fix - Mathieu Arnold's patch to make function naming for autoloaded functions a bit more flexible 0.82 May 19 2003 - Query builder changes to improve some join performance - Fixes to a tight loop for cache expiry 0.81_04 April 14 2003 - Fixed a bug in "Distinct" logic introduced in 0.81_01 0.81_03 April 13 2003 - Patches for Oracle BLOB support from Brook Schofield 0.81_02 April 13 2003 - Rebuilt Postgres query generator. 0.81_01 Mar 27 2003 - Select Distinct altered to support oracle 0.80 Mar 08 2003 - Count method enhanced to ignore "LIMIT"s - LIMIT behaviour changed to be handle specific 0.79 Jan 19 2003 - ReadableAttributes and WritableAttributes added as methods to Record.pm 0.78 Jan 16 2003 - SB->Count should return no results unless the search is limited - Eliminate a warning on empty searches 0.77 Jan 15 2003 - No longer attempt to cache (and fail) objects that haven't been database-loaded 0.76 Dec 30 2002 - 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 Dec 06 2002 - 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 Oct 11 2002 - Adding support for mysqlPP 0.73 Sep 10 2002 - 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 Aug 28 2002 - Fixed bug in setting a column to the value of an SQL statement. 0.70 Aug 27 2002 - Better support for Postgres 7.2 and transactions. 0.62 Jul 5 2002 - 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 May 23 2001 - SearchBuilder.pm - refactored to allow LEFT joins. 0.31 Say May 12 14:45:00 EDT 2001 - 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 Fri May 11 14:59:17 EDT 2001 - 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 Tue Aug 29 16:08:54 2000 - original version; created by h2xs 1.19