DBIx-SearchBuilder-1.81/0000755000076500000240000000000014552307765014347 5ustar sunnavystaffDBIx-SearchBuilder-1.81/inc/0000755000076500000240000000000014552307764015117 5ustar sunnavystaffDBIx-SearchBuilder-1.81/inc/Module/0000755000076500000240000000000014552307764016344 5ustar sunnavystaffDBIx-SearchBuilder-1.81/inc/Module/Install/0000755000076500000240000000000014552307764017752 5ustar sunnavystaffDBIx-SearchBuilder-1.81/inc/Module/Install/Fetch.pm0000644000076500000240000000462714552307762021350 0ustar sunnavystaff#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @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.81/inc/Module/Install/Metadata.pm0000644000076500000240000004343714552307762022041 0ustar sunnavystaff#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @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', artistic => 'http://opensource.org/licenses/artistic-license.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', 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, # these are not actually allowed in meta-spec v1.4 but are left here for compatibility: apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; DBIx-SearchBuilder-1.81/inc/Module/Install/AutoInstall.pm0000644000076500000240000000416214552307762022550 0ustar sunnavystaff#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @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.81/inc/Module/Install/Win32.pm0000644000076500000240000000340314552307762021210 0ustar sunnavystaff#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @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.81/inc/Module/Install/ReadmeFromPod.pm0000644000076500000240000001016414552307762022774 0ustar sunnavystaff#line 1 package Module::Install::ReadmeFromPod; use 5.006; use strict; use warnings; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.30'; { # these aren't defined until after _require_admin is run, so # define them so prototypes are available during compilation. sub io; sub capture(&;@); #line 28 my $done = 0; sub _require_admin { # do this once to avoid redefinition warnings from IO::All return if $done; require IO::All; IO::All->import( '-binary' ); require Capture::Tiny; Capture::Tiny->import ( 'capture' ); return; } } sub readme_from { my $self = shift; return unless $self->is_admin; _require_admin; # Input file my $in_file = shift || $self->_all_from or die "Can't determine file to make readme_from"; # Get optional arguments my ($clean, $format, $out_file, $options); my $args = shift; if ( ref $args ) { # Arguments are in a hashref if ( ref($args) ne 'HASH' ) { die "Expected a hashref but got a ".ref($args)."\n"; } else { $clean = $args->{'clean'}; $format = $args->{'format'}; $out_file = $args->{'output_file'}; $options = $args->{'options'}; } } else { # Arguments are in a list $clean = $args; $format = shift; $out_file = shift; $options = \@_; } # Default values; $clean ||= 0; $format ||= 'txt'; # Generate README print "readme_from $in_file to $format\n"; if ($format =~ m/te?xt/) { $out_file = $self->_readme_txt($in_file, $out_file, $options); } elsif ($format =~ m/html?/) { $out_file = $self->_readme_htm($in_file, $out_file, $options); } elsif ($format eq 'man') { $out_file = $self->_readme_man($in_file, $out_file, $options); } elsif ($format eq 'md') { $out_file = $self->_readme_md($in_file, $out_file, $options); } elsif ($format eq 'pdf') { $out_file = $self->_readme_pdf($in_file, $out_file, $options); } if ($clean) { $self->clean_files($out_file); } return 1; } sub _readme_txt { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README'; require Pod::Text; my $parser = Pod::Text->new( @$options ); my $io = io->file($out_file)->open(">"); my $out_fh = $io->io_handle; $parser->output_fh( *$out_fh ); $parser->parse_file( $in_file ); return $out_file; } sub _readme_htm { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.htm'; require Pod::Html; my ($o) = capture { Pod::Html::pod2html( "--infile=$in_file", "--outfile=-", @$options, ); }; io->file($out_file)->print($o); # Remove temporary files if needed for my $file ('pod2htmd.tmp', 'pod2htmi.tmp') { if (-e $file) { unlink $file or warn "Warning: Could not remove file '$file'.\n$!\n"; } } return $out_file; } sub _readme_man { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.1'; require Pod::Man; my $parser = Pod::Man->new( @$options ); my $io = io->file($out_file)->open(">"); my $out_fh = $io->io_handle; $parser->output_fh( *$out_fh ); $parser->parse_file( $in_file ); return $out_file; } sub _readme_pdf { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.pdf'; eval { require App::pod2pdf; } or die "Could not generate $out_file because pod2pdf could not be found\n"; my $parser = App::pod2pdf->new( @$options ); $parser->parse_from_file($in_file); my ($o) = capture { $parser->output }; io->file($out_file)->print($o); return $out_file; } sub _readme_md { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.md'; require Pod::Markdown; my $parser = Pod::Markdown->new( @$options ); my $io = io->file($out_file)->open(">"); my $out_fh = $io->io_handle; $parser->output_fh( *$out_fh ); $parser->parse_file( $in_file ); return $out_file; } sub _all_from { my $self = shift; return unless $self->admin->{extensions}; my ($metadata) = grep { ref($_) eq 'Module::Install::Metadata'; } @{$self->admin->{extensions}}; return unless $metadata; return $metadata->{values}{all_from} || ''; } 'Readme!'; __END__ #line 316 DBIx-SearchBuilder-1.81/inc/Module/Install/WriteAll.pm0000644000076500000240000000237614552307762022041 0ustar sunnavystaff#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @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.81/inc/Module/Install/Can.pm0000644000076500000240000000640514552307762021014 0ustar sunnavystaff#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.21'; @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; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } 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 245 DBIx-SearchBuilder-1.81/inc/Module/Install/Include.pm0000644000076500000240000000101514552307762021666 0ustar sunnavystaff#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.21'; @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.81/inc/Module/Install/Makefile.pm0000644000076500000240000002743714552307762022040 0ustar sunnavystaff#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.21'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 DBIx-SearchBuilder-1.81/inc/Module/Install/Base.pm0000644000076500000240000000214714552307762021164 0ustar sunnavystaff#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.21'; } # 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.81/inc/Module/AutoInstall.pm0000644000076500000240000006231114552307762021142 0ustar sunnavystaff#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.21'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::getcwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed, @modules_to_upgrade ); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (_version_cmp(_version_of($pkg), $ver) >= 0) { push @installed, $pkg; if ($UpgradeDeps) { push @modules_to_upgrade, $pkg, $ver; } } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @modules_to_upgrade; @installed = (); @modules_to_upgrade = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::getcwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1197 DBIx-SearchBuilder-1.81/inc/Module/Install.pm0000644000076500000240000002714514552307762020317 0ustar sunnavystaff#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.21'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $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( {no_chdir => 1, wanted => 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($File::Find::name); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }}, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } 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; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _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.81/SIGNATURE0000644000076500000240000001663014552307765015641 0ustar sunnavystaffThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.88. 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: SHA256 SHA256 cd49c62f0302b9b1526486dc4dc8d43e6a04bc9ea86baefe70accff48e88c38c .gitignore SHA256 5aba68e35a91fe2580f5e741d9f843dbcb26b7aaea1b70344cb313468e23dec0 Changes SHA256 2e8dc68ceeb4a6d3bc5a8bee3cab2cc3b8a21fb8bf9615b5e5dca94bd2d41eba MANIFEST SHA256 370634a199ba5234aaa4e6cd2ed8527cbf59abfa587961695358a8f6099dd3d3 META.yml SHA256 fab91a84c3320f6958991a1d5599fb316ea03346f9ae916eace9149cf32e97ca Makefile.PL SHA256 9f7133da49e88bcd56595ae487dc71d4aac8d4f4f5e77f443e9e28ba6c12c247 README SHA256 5f8c1ab450da2f3ba8373cda64706ef8e240a52034c03d6e97787b24c518f498 ROADMAP SHA256 b7c61a9d0ba3656c954b520772a0f74a01792a5ca8d060131a2fb7eed42f2ae0 ex/Example/Model/Address.pm SHA256 f4921f5b2e770e12141d57980e5babc8b207455275b4796d0baa77d588f058f5 ex/Example/Model/Employee.pm SHA256 fa2ccffe62a0558135516c479c12d24259355eb0186cbf1b203b67009447503f ex/create_tables.pl SHA256 0ab36e7e7af06b847b17cfe25f01d8a1f67d1db418c5a311a0f3f6d5af7091c0 inc/Module/AutoInstall.pm SHA256 cd5397bbe618f5bbd4e12a33b0cf5d21114e771c2dbd0ce28e2135beb52c35a8 inc/Module/Install.pm SHA256 22540b8bec39fc9b68994495bcf1afbadf4c0405625bc3d683b67ed0a52fa070 inc/Module/Install/AutoInstall.pm SHA256 798836f9ccb8d204b1be31fc3835631f57e9d818b21a8f0d14bfcfb82ff4a72a inc/Module/Install/Base.pm SHA256 d64cd4c16f83c5baf11f64a44bea3a0abc060a49da5aba040f0eb01394bf75ab inc/Module/Install/Can.pm SHA256 65d7a6098bf3f829e8c1c2865476d3537aa6f0ad0ffc9149e10812c856529043 inc/Module/Install/Fetch.pm SHA256 aa71b16c882fd2d8af83ac3e9761ef314bb45627905359435ae986d3129b199a inc/Module/Install/Include.pm SHA256 70c4b77acab3ff51dfb318110369607cb109e1c319459249623b787cf3859750 inc/Module/Install/Makefile.pm SHA256 14556386168007ce913e669fc08a332ccdb6140246fd55a90c879b5190c1b57a inc/Module/Install/Metadata.pm SHA256 53825bc78e4c910b888160bc148c8bc211be58e02b99c8edcbf4854f95faa049 inc/Module/Install/ReadmeFromPod.pm SHA256 4c746c02c5cc19bed4c352e76205b4adff4c45ce8310d71294e1b83c059659c2 inc/Module/Install/Win32.pm SHA256 d3d9b4583243c470ae895defa4c44564485b53693cba1c50ab0320768f443e97 inc/Module/Install/WriteAll.pm SHA256 799a868c3517da5f2d4a0694d09ddfa7cc3354fa67b89eec800095bc6021ce57 lib/DBIx/SearchBuilder.pm SHA256 14f5fe25a25e4176e6f80737160263a28e7d7b439ca463df919eee3d424b61fc lib/DBIx/SearchBuilder/Handle.pm SHA256 bd58a6691a71753a9c85b22d4ec2cb9f27e51744cfcfd798da775b9b84752799 lib/DBIx/SearchBuilder/Handle/Informix.pm SHA256 dcc3310f2b3b4f7935347ad255b60e64da7db53bea22af961d60dcc5620c48ec lib/DBIx/SearchBuilder/Handle/MariaDB.pm SHA256 cb878703a936011e21c6d10cd00e03d7fbef60704ecd48b301fe76cfb9a3bdae lib/DBIx/SearchBuilder/Handle/ODBC.pm SHA256 2a8f037dfad9f62fa4d454d57f247de593eebc309281bd68b790297ba4e6885f lib/DBIx/SearchBuilder/Handle/Oracle.pm SHA256 0c7dc3f8ee483b4a596566c012a53b70896808d8865de40957c4c8fd0d3c74ab lib/DBIx/SearchBuilder/Handle/Pg.pm SHA256 32ae1aba7ea301e45e5cff78f7d9f004fd77e432e6e3d1633095bec0aebc7c48 lib/DBIx/SearchBuilder/Handle/SQLite.pm SHA256 86fe15e416d699c5b7a7256001eb67c9ba2717fe0011966a3aa421ccc2475c4e lib/DBIx/SearchBuilder/Handle/Sybase.pm SHA256 d4f5bff16921a4cc44ba71f28adcc57704d31e88b6d9a5a10d40c02f358e83d9 lib/DBIx/SearchBuilder/Handle/mysql.pm SHA256 b8f2c2e86518e0d77e5a75f88d5bcaffd0d3c8328f1dcb1e3d5a00949d478bf4 lib/DBIx/SearchBuilder/Handle/mysqlPP.pm SHA256 ec0554a53bc14bd442e17654a1f8fc8d9ee8cc0c22e244c5ae5000cd3a3b812f lib/DBIx/SearchBuilder/Record.pm SHA256 c0b49a3257cd6aa5abdbd6da2bd5e67d9263557d7c665aec914491695ee93650 lib/DBIx/SearchBuilder/Record/Cachable.pm SHA256 a930f8b893cb38b8c2ef5de189511ccdcc4dca53adb160baee1bb52331a8a410 lib/DBIx/SearchBuilder/SchemaGenerator.pm SHA256 9c94d1806060eb253100fe7fcaea156513d0dccdd1e7d089ff5e5a01ef224091 lib/DBIx/SearchBuilder/Union.pm SHA256 04b3f737565a30a2871280baec90653830f6fb008e9c7657bf39533967c727bc lib/DBIx/SearchBuilder/Unique.pm SHA256 f4298ca835eaf58766f495746abd6f6d6e8abf74320bbf0f60ab3084ee478792 lib/DBIx/SearchBuilder/Util.pm SHA256 7216724c027aa08e83f9f149cd49358bd7a91a978dad6951100258ed19df3cc0 t/00.load.t SHA256 ef7b9c19814507d98043c4b634fad449020fc1babfb82dcf07a5e870302816db t/01basics.t SHA256 0f4f676f79565d56a6659213409d9ae0c0e93c21f9e93dbd282a7a651b7bdeeb t/01nocap_api.t SHA256 a6c8d0de54835b83e24a03e2e2c07d413f8871873982f651ef1f7c1c4747391b t/01records.t SHA256 73bc4b6685ce42610e1507fd06865e9089f2f4a42c12ee816fd14cf06235e276 t/01searches.t SHA256 f78222b49a1f44dc5e0a973e599b8de69e2eae582dcbc74f794e2d8c8a36d292 t/02distinct_values.t SHA256 32744fe6e991460d052bc4aeb7610081dbb6aaa680c1d6a4c8d68baa454d8cc9 t/02null_order.t SHA256 3c7f9f248a592656f6c3513ba5192a2dcd428e93ef26b60a8b0e5e38b8be8975 t/02order.t SHA256 b37251ced9381fdc20f4c81fe371cfc9480bd98ef34623d443f8ffcc44ec2930 t/02records_cachable.t SHA256 5459c81a7ae1f220bb6458370735feeb9537e203a5bbd61f4c7494be8bccc931 t/02records_datetime.t SHA256 713df8bacae9620ff91accfddc62e9a90e5c21541191a3e463d49471def59e3e t/02records_dt_interval.t SHA256 a1198b59a73bbd21e36bfde0656c027d5649b497252d3ebf084ad9e778e9f627 t/02records_integers.t SHA256 df49aa5630a58d4ab67de82403e0e23419e2d922f7e2ca6b2389cbc9f4c60048 t/02records_object.t SHA256 5aca04b4be98f21a00a4cdc69338e20f14ad4c41ebaa19e280569c8946c49f3c t/02searches_function.t SHA256 f099ae6824b95bbf5e8e67178bc2a762c08482d6e5864e57a3fac01add2eaed3 t/02searches_joins.t SHA256 5ece6c29b1b486f9108aed888aa6b6f5f477e6168718b14022bf6cffe995485b t/03compatibility.t SHA256 70aa2c527d45f55f90066e9e8f8aab7c9b24a9924b98646d7f849f4dcf4f1c08 t/03cud_from_select.t SHA256 cf1bf26bc170c882ba305ad395a47ffab602ba0b8cf2cb2fca644bff090dcd87 t/03rebless.t SHA256 84f227a91f3e25c70aa75e73a75ab0d517d02e9f1a85d1495499a412d6669f27 t/03searches_bind.t SHA256 872b990b4e4bd40cd67e2ec29c0ae4b703b4cf139aec1e7ad0a98bd47cb3886f t/03searches_combine.t SHA256 8386a027a701cbfeb784931150351629ad2fdc8a0787dfcc7e570657e5d77893 t/03transactions.t SHA256 751c1b02433499fb4d84bdcb5629b998092833b068b23c8d3f93f9f019aded42 t/03versions.t SHA256 7b601f8172ccfec55b01d68f500e9c5b97d6485f2a65f10ce212245db77b6c93 t/04mysql_identifier_quoting.t SHA256 6e2e6fc5baf627cd9c7704fcf8be04240994b63acddb566bb16f64ac422d1816 t/10schema.t SHA256 a59237bd466da977ce4a8fd62bc6338062266af418df5f51535e416441cbef5e t/11schema_records.t SHA256 28cc1683ab51ba6fc11b3e2175d0c37d68bf36adf4ff4a6c671716562b3858f7 t/20set_edge_cases.t SHA256 b0db96e65e2b5300f140170b054f3b6c4bb171240b085f4d5e21f16f961bcac9 t/pod.t SHA256 9cc94435aee3fee6d9a9e028c7fb70050b3b80810b082f6c9bac2f2bd91c6b3d t/testmodels.pl SHA256 94b10fbc45241e8fa764a8679b06568b18489af0b549fa42164fe2df21cf4940 t/utils.pl -----BEGIN PGP SIGNATURE----- iQEzBAEBCAAdFiEExJs3Lyv4ShkBFmAnDfCig/6sgLIFAmWpj/UACgkQDfCig/6s gLKzDgf/WunmeDFu4b09hphmu64dnAPFwvFPxuuc/+8DcCPHSqxr2oRlJi0B+STS 4J7HKj9ZSq6qy5WGhLVk+nFfHJ2y3BxmJ08+DzJRm7zYLpDFSMBSoCaGpV5AEx+b TbDGqNF25ZGxWlbBdvs1iVfqXOGEfJFMj3bavSfeARblyODQiYAlJE7tTa2El0wv m2po2MeTZKdpaz8VJPA6S/lgHH8Nv+0vNMBGypM3wSNVzl2iS4lBIIFQRkbk655n 11/TBkyNujBabMmtEWuIEgtcnR86Oq7YE5mQTHdCxZ29avohMP5fG1eETY/4K4JB tjW+AmEturPkfGY3zg4XbbH1jcUbdg== =4Sdx -----END PGP SIGNATURE----- DBIx-SearchBuilder-1.81/ROADMAP0000644000076500000240000000522714370111524015343 0ustar sunnavystaffThings 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.81/Changes0000644000076500000240000005460014552307724015642 0ustar sunnavystaffRevision history for Perl extension DBIx::SearchBuilder. 1.81 2024-01-18 - Add explicit support for MariaDB in addition to MySQL 1.80 2023-12-13 - Add CastAsDecimal helper method 1.79 2023-11-27 - Produce correct query hints 1.78 2023-07-05 - Query the Count data if current page does not have any records - Require DBD::SQLite 1.60+ for combine searches 1.77 2023-06-30 - Change how DistinctQueryAndCount builds query to fix sorting 1.76 2023-04-20 - Call DatabaseVersion instead to make sure we already retrieved the version (this is to fix a possible uninitialized warning on disconnect) 1.75 2023-04-19 - Log unsupported CombineSearchAndCount warning only once - Fix version comparison for MariaDB 10.10+ 1.74 2022-12-12 - Explicitly require version to make cpantesters happy - Require perl 5.10.1+ to not support derelict versions 1.73 2022-12-08 - Remove very old CVS headers from files - Standardize whitespace - Remove an unused cache parameter remaining from a previous refactor - Update a test to work around a change in numeric values returned on Postgres starting in version 14 - Fix a doc typo - Fix a bind value issue with Limit on Postgres - Disable finding count in searches for older versions of MySQL and MariaDB that don't support window functions (OVER) - Truncate values before checking for changes to fix a bug where values bigger than a column would be inserted even when they were not changed 1.72_01 2022-09-20 - Simplify count's internal logic to always use the "count_all" key - Fix Count method to always returns count in selected page - Support search and count in same query - Redo search only if ORDER/GROUP BY is really updated - Add bind values support for LIMIT clauses 1.71 2021-09-24 - Add dot to load utils in tests for perl 5.26+ 1.70 2021-09-24 - Enable queries processed with BuildSelectQuery and BuildSelectCountQuery to use bind variables 1.69 2021-01-20 - New option to quote tablenames in queries, enabled automatically for MySQL 8 - Updated tests for new MySQL 8 reserved words and tablename quoting 1.68 2020-07-06 - Avoid segmentation faults on disconnect on MariaDB 10.2+ 1.67 - Add ->QueryHint and ->QueryHintFormatted to collection API for Oracle 1.66 - No changes since 1.65_02 1.65_02 - Stop unilaterally disabling the "UTF8" flag before executing queries - Make ->Fields case-sensitive in the column names it returns, as well as in the table name it takes. 1.65_01 - Make ->Fields only lookup information on the table requested, not all fields, for performance. It also is now case-sensitive in table name. - Omit calls to ->Fields entirely for PostgreSQL 9.1 and above 1.65 2013-07-03 - Bug fix for DateTimeInterval extraction on Pg 1.64 2013-07-01 - No changes since 1.63_03. Simply a non-dev release of everything since 1.63. 1.63_03 2013-06-14 - warn when rollback and commit are mixed - Handle->NullsOrder - skip timezone tests on SQLite when tzinfo is not there - skip tests if mysql can not do timezones - DISTINCT argument in Join method - DISTINCT argument in Join and NewAlias - Reset the iterator position whenever a search is run - Return the correct record from ->Last instead of the first record - Document the caveat of using GotoItem with a non-zero N 1.63_02 2013-04-17 - _Set now can take undef as argument to mean default or NULL. Still may result in error if default is not defined and no_nulls is true for the column. If old behaviour is required set $record->{'no_undefs_in_set'} to true value. - FUNCTION argument is now allowed in Limit. Code to combine FUNCTION, ALIAS and FIELD was refactored and unified in one place - CombineFunctionWithField method. Used in Column, GroupBy and Limit. This change should be backwards compatible. - Handle->DateTimeIntervalFunction 1.63_01 2013-03-27 - IN and NOT IN operators in ->Limit method - Add an AdditionalColumn method to collections - Add an AS parameter to Column method in collections - Consistent query generation by sorting hash keys/values 1.63 2012-09-14 - joins_are_distinct hint to indicate that distinct is not required for the current set of joins. 1.62 2012-03-26 - Bind values were ignored in SimpleUpdateFromSelect 1.61 2011-09-16 - New methods in Handle for mass changes from select statements: InsertFromSelect, DeleteFromSelect and SimpleUpdateFromSelect - New methods in Handle for generation of date time related SQL 1.60 2011-09-15 - custom BuildDSN for Oracle - Database is treated as SID if SID is not provided - Build 'dbi:Oracle:' instead of 'dbi:Oracle:sid=' - changes in DBIx::SearchBuilder->Column method - complete documentation - support for empty FIELD argument - column naming fix when explicit ALIAS => 'main' passed 1.59 2010-11-19 - DBIx::SearchBuilder->DistinctFieldValues method 1.58 2010-10-20 - SIGNATURE fix - delete obsolete cvs metadata from a module 1.57 2010-09-04 - INCOMPATIBLE CHANGE: NextPage and PrevPage were adding rows from the previous page. Jesse claims that when he wrote this code, he was 20 years old and it seemed like a good idea at the time. - When logging queries, include full stack trace - support $sb->NewAlias( 'table' => 'LEFT' ); - allow join to depend on nothing - catch cases when there are more closing parens then should be - Oracle: Use ROW_NUMBER() to propagate row ordering from inside the DISTINCT - Various performance improvements through small internal refactorings - Implemented 'sub Fields' on Oracle - unify case insensitive characters to avoid using LOWER() in some cases - We now RedoSearch when RowsPerPage is changed - No longer RedoSearch if FirstRow is called, but is not actually changed - Document all paging functions and test them - handle LOWER() in redundant LEFT joins optimizer, for Oracle and may be Pg - Make debugging problems easier by passing errors back https://rt.cpan.org/Ticket/Display.html?id=55203 - fix Record->PrimaryKeys, field names in values hash are lc'ed https://rt.cpan.org/Ticket/Display.html?id=18280 - doc updates and cleanups 1.56 2009-07-17 - Don't use LOWER/ILIKE with dates, heuristic is used, but shouldn't harm other things - Don't apply DISTINCT on queries with group by, COUNT(DISTINCT x) is different and covered in Column method 1.55 2009-05-07 - Put test suite SQLite databases inside of tempdirs so they get garbage collected properly. Thanks to Andreas Koenig [rt.cpan.org #41322] - Allow ->Join to pre-existing collection object - Imlement and test SB::Handle::Fields - Pg can not guaranty order in the following queries: SELECT ... FROM (SELECT... ORDER BY ...) we use them to build distinct sets with ordering by columns in joined tables. Switched to group by instead of sub-selects. 1.54 2008-07-09 - When aborting transactions, we need to flush our cache, because SQLite is reusing the primary id for later inserts and the cache can otherwise become inconsistent. 1.53 2008-04-02 - Fix mysql version check in DistinctQuery function - Fix order by outer column on Oracle - Improve tests 1.52 2008-04-01 - Fix order by outer column on SQLite, mysql, adjust Pg. Add test that cover this. 1.51 2008-01-15 - Fix CountAll method when paging is enabled and data is in memory already 1.50 2007-11-23 - Oracle: Don't DISTINCT query when there is a group by clause - Fix a problem when we have more then two collections in a union and some of them are empty 1.49 2007-07-07 - Fix a CPAN signature issue 1.48 2007-03-11 - Fix a problem when left joins optimizer fails to calculate a boolean expression because of lower case aggregators. 1.47 2007-03-04 - Do the search in unions only when we must do them, not on every call to the Next method - Don't index ex/ dir to avoid complains by the indexer of PAUSE/CPAN 1.46 2007-02-25 - when doing a union, we need to actually search, rather than just doing a count - add support for testing with Oracle backend - Use CROSS JOIN instead of ',' as SQL parsers in Pg and some mysql are buggy and cannot parse "FROM X, Y JOIN Z ON Z.f = X.f" - deprecate DEBUG method, it's still there but produce warning - fix CleanSlate method that was missing several keys - fix a long standing bug we had, we didn't write depends_on data about a join, so we could build queries with incorrect parens around join conditions - fix default values for ALIAS1 argument in the Join method, istead of defaulting FIELD1 to 'main' value - fix a TODO test - internal refactoring of a storage for query's conditions, instead of building query strings right after the limit or join, we now build a perl structure - don't clone attributes that don't exists in the Clone method - we use Encode module without perl version check for a long time, so we can get rid of all checks for the version and load the module at compile time everywhere we need it - implement MayBeNull method in the handler that checks if applied conditions allow NULLs in the result set - implement cascaded LEFT JOINs optimization - additional tests for CleanSlate and Clone methods, ENTRY_AGGREGATOR argument, different types of joins and LEFT JOIN optimizer 1.45 2006-09-26 - Postgres: fix "$rec->Create();" - Postgres: fix "$rec->Create( IntegerColumn => '' );" - Postgres: fix "$rec->SetIntegerColumn( '' );" - Postgres: add test - cleanup ::Record::Cachable - use cache in: $a->LoadByCols(...); $b->LoadById( $a->id ); - add cache tests 1.44 2006-05-27 - DBIx::SearchBuilder::Handle::DatabaseVersion enhancements 1.43 2006-04-12 - Fix to the sequence compatibility fixes. For backwards compatibility. 1.42 2006-04-10 - Signatures fixed 1.41 2006-04-10 - PG 8.1 sequence compatibility fixes from Daniel Tabuenca 1.40 2006-03-10 - 'NOT STARTSWITH' and 'NOT ENDSWITH' 1.39 2006-02-16 - Allow ORs on left joins 1.38 2005-12-29 - Released 1.37 dev series 1.37_01 2005-12-08 - Switched Postgres sequence lookups to use CURRVAL, rather than OIDs 1.36 2005-12-02 - Change to how we resolve virtual columns to deal with a "no such attribute" bug in RT 1.35 2005-11-02 - Doc fixes and OrderBy cleanup from ruslan 1.34 2005-11-02 - Clone support from Ruslan 1.33 2005-09-22 - Better SQL statement logging from alex 1.32 2005-09-01 - DBD::SQLite is necessary for the test suite to run correctl 1.31 2005-07-29 - Updated MANIFEST to fix a build issue - Thanks to Andy Lester and David Glasser 1.30_03 2005-06-09 - Significant new tests from Ruslan Zakirov and Dave Glasser - You no longer need to explicitly bless a DBIx::SearchBuilder::Handle subclass - Start of a major overhaul of the subclass API for DBIx::SearchBuilder::Record objects. A new "schema" method will define the data in _ClassAccessible and also generate database schema using DBIx::DBSchema. - for numeric types, make the empty check be "null or 0", not "null or ''" - New search tests from ruslan - added an init_data method to t/utils.pl - CleanSlate doesnt init show_rows - CleanSlate doesnt clean _{open|close}_parens - get rid of stupid ifs in CleanSlate - get rid of evals in _DoSearch and _DoCount, use Handle methods to control DBI error handling - rewrite LoadByPrimaryKeys args handling to consistent with other Load* methods - report error when PK filed is missing in LoadByPrimaryKeys - fix warning in __Set methods when newvalue is undef - small code cleanups - test coverage grows from 75.2% to 84.7% for Record.pm 1.30_02 2005-05-22 - Lots of patches from Ruslan: First and main change is using of `goto &$AUTOLOAD` syntax, that helps avoid code duplication and hides AUTOLOAD sub from stack trace. I think this also would help implement CompileAllAutoSubs method easier. - It's also one of the steps to better tests coverage. - Test coverage for Record.pm grows from 66% to 75.2%. - _LoadFromSQL never reported error when PK fields are missed. Fixed. - fetchrow_hashref dies only when RaiseErrors is true, because we can control this from Handle obj so we should die according to $Handle->RaiseErrors property. Fixed. - When RaiseErrors is "false" then fetchrow_hashref returns undef and we should check $sth->err(see `perldoc DBI`). Fixed. - After call to fetchrow we should clean "fetched" internal hash and fill it only when we return successful result. Fixed. - If SimpleQuery fails, _LoadFromSQL method doesn't return any error message. Fixed. 1.30_01 2005-05-16 - Patches from Ruslan to switch to using 'capitalization.pm' for our regular_case subroutine aliases 1.30 2005-07-28 - Removed {{{ and }}} fold markers. Patch from Ruslan 1.27 2005-05-08 - Added supoprt for functions containing "?" to represent the parameter in ->Column() - Added better support for functional columns in search listings and group by clauses 1.26 2005-04-17 - Added support for expression based left joins 1.25 2005-04-09 - Backed out a change introduced in 1.23 that caused table and column names to be quoted, causing Postgres to flip out. 1.24 2005-04-06 - Added a new "SearchBuilder::Unique" module for uniquifying search results 1.23 - Now use DBI->quote_identifier to quote column and table names (Ruslan) - Test suite updates (Ruslan) 1.22 2005-01-24 - Require encode since we require encode. 1.21 2005-01-22 - Oracle LOB handling caused us to corrupt item values on update. - Just before inserting things into the database, turn off their utf8 flag. The flag didn't have any positve impact _and_ it can take down recent DBD::Oracle releases. (This is a new failure in DBD::Oracle 1.16) 1.20 2005-01-18 - Minor test suite fixes from Ruslan. 1.19 2005-01-08 - Performing a search multiple times could result in multiple copies of records in a collection. Uncovered thanks to Kevin Chen and Alex Vandiver. 1.18 - Release the changes from 1.17 1.17_03 - Properly mark BLOB columns in UPDATE calls. (DBD::Oracle 1.16 broke without this) 1.17_02 - Better handling of empty values for SB::Record::_Accessible. ( --Ruslan) 1.17_01 - More record tests from Ruz 1.16 2004-12-09 - Fixed a bug in D::SB::R::Cachable that could cause it to load the wrong row from the cache if you were loading by alternate keys and had since changed one of the attributes of a previous row. This was unmasked by a bug that Ruslan Zakirov found in RT 3.3's custom field handling 1.15 2004-11-27 - Fix a testsuite bug when DBD::SQLite isn't there 1.14 - Silenced warnings about uninitialized warnings when inserting null cols into the database. - Started adding lowercase method name aliases - Minor refactoring of 'id' method for a stupid, tiny perf improvement - Refactoring of DBIx::SearchBuilder::Record::Cachable for performance improvement - Added a FlushCache method to DBIx::SearchBuilder::Record::Cachable. - Started to flesh out a...test suite - SearchBuilder now truncates strings before inserting them into character types in the database as mysql generally does. Additionally, it truncates things at utf8 character boundaries...as mysql does not. - Fix for an undefined record cache warning on load from Autrijus Tang - Major documentation cleanups --Simon Cavalletto - A few tweaks to the ::Record class to eliminate the hard-coding of the name of the id column --Simon Cavalletto 1.12 - Better error handling for some query build failure cases - Corrected query builder for SQLite - More refactoring. 1.11 - When loading an object whose "id" has been altered, as in the case of RT's "Merge" functionality, the wrong object was returned by the caching layer. Special casing for the "id" method was removed. 1.10_05 - Reworked the _Accessible mechanism in DBIx::SearchBuilder::Record to remove a horribly crufty old caching mechanism that created a copy of the accessible hash for each and every object instantiated, sometimes quite slowly. 1.10_04 2004-08-30 - A query builder fix for an issue that bit RT2: Unsatisfied dependency chain in Joins Users_2 at /usr/local/share/perl/5.8.3/DBIx/SearchBuilder/Handle.pm line 965, line 69. 1.10_03 2004-08-30 - Cache Sanity fixes from Autrijus Tang 1.10_02 2004-08-26 1.10_01 2004-08-26 - Reimplemented DBIx::SearchBuilder:::Record::Cachable to use Cache::Simple::TimedExpiry. This should make it faster and more memory efficient. 1.10 - Identical to 1.10_05 1.02_03 2004-07-22 - Additional bullet proofing for joins. Now we default to ALIAS1 being "main" (cubic@acronis.ru) 1.02_02 2004-07-20 - Fixed a join bug that mostly manifests as a 'Dependency chain' error on RT2. 1.02_01 2004-07-07 - magic _Object instantiation from cubic@acronis.ru - make SB::_Handle settable directly (cubic@acronis.ru) - document the above 1.01 2004-06-27 - Releasing 1.00_06 as stable 1.00_06 - Pg/Oracle: Don't attempt to do case insensitive comparisons on integer values. 1.00_05 - Force utf8 flag on when doing searches for utf8 data; this is a workaround for DBDs that don't do it themselves. 1.00_04 - Move Postgres specific join behaviour to the superclass so everyone gets the benefit. 1.00_03 - Remove "AS" from table name aliases on joins, since Oracle doesn't like em. 1.00_02 - Slightly cleaner code in SearchBuilder->GotoPage 1.00_01 - Better handling of case insensitive comparisons on Postgres - Proper support for query paging on SQLite 0.99 - Bundled changes from 0.98* and released production version - Removed duplicate code in cache expiry routines Experimental SearchBuilder::Union collection object. - Released at the YAPC::Taipei::22004 Release Party 0.98_04 - New mysql/oracle "Join" code that allows more complex bundling of joins from Linda and Robert 0.98_03 - New test infrastructure from Andy Lester 0.98_02 - Better handling of != clauses on Postgres 0.97_02 - Support for "Group By" clauses. - Support for delayed load of certain columns from Autrijus Tang. 0.97_01 - Oracle doesn't support binary-safe clobs in a reasonable manner. 0.96_01 - Fix a couple of spurious warnings in Record::Cachable - Records loaded from multiple-record searches were never cached - correctly 0.96 - Releasing 0.96_01 as usable 0.95_03 - Allow case-insensitive loading by columns in SearchBuilder::Record - Record::LoadByCols now lets you specify operator and values 0.95_01 - Removed historical escaping for non-ascii searche queries 0.94 - Fix for multiple handles in one app from Autrijus Tang 0.93 - Added ODBC database driver from Autrijus Tang - Added the ability to sort on functions of columns from Autrijus Tang - Improved case-insensitve searching behavior for PostgreSQL - Added support for multiple handles in one app from Autrijus Tang (#4167) - Added initial Informix database driver from Oliver Tappe 0.92 2003-09-04 - Fixed a bug that caused certain types of pre-canned table aliases to fail to work on join 0.90 2003-08-08 - Disable Class::ReturnValue's stack trace feature as it interacted poorly with a stack containing lots of data 0.89_02 2003-07-19 - Patch from Grant DeGraw to allow ordering by multiple columns. 0.89_01 2003-07-18 - Patch from Brook for: - better oracle support - remove "SELECT DISTINCT" when it's not necessary 0.88 2003-06-23 - More correct generation of "Distinct" keyword on counts for queries with left joins 0.87 2003-06-16 - Changed DBIx::SB::Record::Cachable to expire cached object when a "deeper" method call changes their values 0.86 2003-06-07 - Doing conditional connections was failing on postgres, because the handle was defined, but not connected 0.85 2003-06-07 - Stan's destroy fix was actually badly breaking RT - It's now an optional parameter. 0.84 2003-06-04 - Bumped the version for release 0.83_05 2003-06-02 - Provide support for blowing away nested transactions that aren't yet committed. 0.83_04 2003-06-02 - Fixed how values of returned hashes are downcased. - Should be a minor perf improvement 0.83_03 2003-05-30 - Moved Stan's destryo fix to the right file 0.83_02 2003-05-27 - Better oracle support for unique ids on indexes from Brook 0.83_01 2003-05-27 - Stan's DESTROY fix - Mathieu Arnold's patch to make function naming for autoloaded functions a bit more flexible 0.82 2003-05-19 - Query builder changes to improve some join performance - Fixes to a tight loop for cache expiry 0.81_04 2003-04-14 - Fixed a bug in "Distinct" logic introduced in 0.81_01 0.81_03 2003-04-13 - Patches for Oracle BLOB support from Brook Schofield 0.81_02 2003-04-13 - Rebuilt Postgres query generator. 0.81_01 2003-03-27 - Select Distinct altered to support oracle 0.80 2003-03-08 - Count method enhanced to ignore "LIMIT"s - LIMIT behaviour changed to be handle specific 0.79 2003-01-19 - ReadableAttributes and WritableAttributes added as methods to Record.pm 0.78 2003-01-16 - SB->Count should return no results unless the search is limited - Eliminate a warning on empty searches 0.77 2003-01-15 - No longer attempt to cache (and fail) objects that haven't been database-loaded 0.76 2002-12-30 - Extra checking for cache misses in DBIx::SearchBuilder::Record::Cachable - The start of support for checking database version, so that we can do version-specific SQL - A patch from Autrijus Tang that allows utf-8 safe searching 0.75 2002-12-06 - Applying a patch from Rob Spier which enables arbitrarily complex grouping clauses. It's a hack, but we love it anyway....at least until SB gets redone with proper arbitrarily complex query generation. 0.74 2002-10-11 - Adding support for mysqlPP 0.73 2002-09-10 - More class-returnvalue ification - Fixed a caching bug that caused multiple copies of an object in memory to not be kept in sync 0.72 2002-08-28 - Fixed bug in setting a column to the value of an SQL statement. 0.70 2002-08-27 - Better support for Postgres 7.2 and transactions. 0.62 2002-07-05 - Support for Class::ReturnValue to channel errors up when expected - Dependency on Class::ReturnValue - Minor cleanups and refactorings to allow percolation of errors on create 0.34 2001-05-23 - SearchBuilder.pm - refactored to allow LEFT joins. 0.31 2001-05-12 - SearchBuilder::Record::Cachable now constructs cache keys in a way that doesn't lose when records in different tables have the same keys. 0.30 2001-05-11 - Added DBIx::SearchBuilder::Record::Cachable from - Changed SearchBuilder->Count to do the right thing if no query has been performed - No longer specify a sort order if no sort order was specified ;) 0.01 2000-08-29 - original version; created by h2xs 1.19 DBIx-SearchBuilder-1.81/MANIFEST0000644000076500000240000000322714552307655015502 0ustar sunnavystaff.gitignore Changes ex/create_tables.pl ex/Example/Model/Address.pm ex/Example/Model/Employee.pm inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/ReadmeFromPod.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/DBIx/SearchBuilder.pm lib/DBIx/SearchBuilder/Handle.pm lib/DBIx/SearchBuilder/Handle/Informix.pm lib/DBIx/SearchBuilder/Handle/MariaDB.pm lib/DBIx/SearchBuilder/Handle/mysql.pm lib/DBIx/SearchBuilder/Handle/mysqlPP.pm lib/DBIx/SearchBuilder/Handle/ODBC.pm lib/DBIx/SearchBuilder/Handle/Oracle.pm lib/DBIx/SearchBuilder/Handle/Pg.pm lib/DBIx/SearchBuilder/Handle/SQLite.pm lib/DBIx/SearchBuilder/Handle/Sybase.pm lib/DBIx/SearchBuilder/Record.pm lib/DBIx/SearchBuilder/Record/Cachable.pm lib/DBIx/SearchBuilder/SchemaGenerator.pm lib/DBIx/SearchBuilder/Union.pm lib/DBIx/SearchBuilder/Unique.pm lib/DBIx/SearchBuilder/Util.pm Makefile.PL MANIFEST This list of files META.yml README ROADMAP SIGNATURE t/00.load.t t/01basics.t t/01nocap_api.t t/01records.t t/01searches.t t/02distinct_values.t t/02null_order.t t/02order.t t/02records_cachable.t t/02records_datetime.t t/02records_dt_interval.t t/02records_integers.t t/02records_object.t t/02searches_function.t t/02searches_joins.t t/03compatibility.t t/03cud_from_select.t t/03rebless.t t/03searches_bind.t t/03searches_combine.t t/03transactions.t t/03versions.t t/04mysql_identifier_quoting.t t/10schema.t t/11schema_records.t t/20set_edge_cases.t t/pod.t t/testmodels.pl t/utils.pl DBIx-SearchBuilder-1.81/ex/0000755000076500000240000000000014552307764014762 5ustar sunnavystaffDBIx-SearchBuilder-1.81/ex/Example/0000755000076500000240000000000014552307764016355 5ustar sunnavystaffDBIx-SearchBuilder-1.81/ex/Example/Model/0000755000076500000240000000000014552307764017415 5ustar sunnavystaffDBIx-SearchBuilder-1.81/ex/Example/Model/Address.pm0000644000076500000240000000053514370111525021325 0ustar sunnavystaffpackage 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.81/ex/Example/Model/Employee.pm0000644000076500000240000000033714370111525021517 0ustar sunnavystaffpackage 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.81/ex/create_tables.pl0000644000076500000240000000323114370111525020075 0ustar sunnavystaff#!/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.81/t/0000755000076500000240000000000014552307764014611 5ustar sunnavystaffDBIx-SearchBuilder-1.81/t/pod.t0000644000076500000240000000020114370111525015533 0ustar sunnavystaffuse 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.81/t/02order.t0000644000076500000240000001775614552307427016267 0ustar sunnavystaff#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 363; 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"); } } my @fields = ( 'Name', $d eq 'Oracle' ? 'TO_CHAR(Name)' : ($d eq 'mysql' || $d eq 'MariaDB') ? 'BINARY(Name)' : 'CAST(Name AS TEXT)' ); diag "test ordering objects by fields on Tags table" if $ENV{TEST_VERBOSE}; foreach my $direction ( qw(ASC DESC) ) { foreach my $field (@fields ) { foreach my $combine_search_and_count ( 0, 1 ) { foreach my $per_page (0, 5) { foreach my $page (0, 2) { my $objs = TestApp::Objects->new($handle); $objs->CombineSearchAndCount($combine_search_and_count); $objs->UnLimit; my $tags_alias = $objs->Join( TYPE => 'LEFT', ALIAS1 => 'main', FIELD1 => 'id', TABLE2 => 'Tags', FIELD2 => 'Object', ); ok($tags_alias, "joined tags table"); # Generated SQL is MIN(Name) or nested functions like MIN(CAST(Name AS TEXT)) $objs->OrderBy( ALIAS => $tags_alias, FIELD => $field, ORDER => $direction ); $objs->RowsPerPage($per_page) if $per_page; $objs->GotoPage($page) if $page; 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); } }; my $got_count = $objs->CountAll; is ($got_count, 30, "CountAll is expected"); }}}}} # foreach variants blocks my $expected_count = 0; diag "test ordering objects by object's fields with limit by tags" if $ENV{TEST_VERBOSE}; foreach my $direction ( qw(ASC DESC) ) { foreach my $field ('Name', 'id') { foreach my $combine_search_and_count ( 0, 1 ) { foreach my $per_page (0, 5, 30) { foreach my $page (0, 2) { my $objs = TestApp::Objects->new($handle); $objs->CombineSearchAndCount($combine_search_and_count); my $tags_alias = $objs->Join( ALIAS1 => 'main', FIELD1 => 'id', TABLE2 => 'Tags', FIELD2 => 'Object', ); ok($tags_alias, "joined tags table"); $objs->OrderBy( FIELD => $field, ORDER => $direction ); $objs->RowsPerPage($per_page) if $per_page; $objs->GotoPage($page) if $page; $objs->Limit( ALIAS => $tags_alias, FIELD => 'Name', OPERATOR => 'IN', VALUE => ['c', 'a'] ); my @list; while ( my $obj = $objs->Next ) { push @list, $field eq 'Name'? $obj->Name : $obj->Id; } my @correct = sort {$field eq 'Name'? $a cmp $b : $a <=> $b } @list; @correct = reverse @correct if $direction eq 'DESC'; is_deeply(\@list, \@correct, "correct order"); my $got_count = $objs->CountAll; if ($expected_count) { is($got_count, $expected_count, "count is correct"); } else { $expected_count = $got_count; } }}}}} # foreach variants blocks cleanup_schema( 'TestApp', $handle ); }} # SKIP, foreach driver block 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) )", "CREATE INDEX Tags1 ON Tags (Name)" ] } sub schema_mariadb { [ "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) )", "CREATE INDEX Tags1 ON Tags (Name)" ] } 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) )", "CREATE INDEX Tags1 ON Tags (Name)" ]} 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) )", "CREATE INDEX Tags1 ON Tags (Name)" ]} 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) )", "CREATE INDEX Tags1 ON Tags (Name)" ] } 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.81/t/02null_order.t0000644000076500000240000001044514552307427017305 0ustar sunnavystaff#!/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.81/t/02records_object.t0000644000076500000240000001001714552307427020122 0ustar sunnavystaff#!/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_mariadb { [ 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.81/t/03compatibility.t0000644000076500000240000000137414431214576020011 0ustar sunnavystaff#!/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.81/t/01nocap_api.t0000644000076500000240000000171314431214576017064 0ustar sunnavystaff#!/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.81/t/04mysql_identifier_quoting.t0000644000076500000240000000111214431214576022244 0ustar sunnavystaff#!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 7; BEGIN { use_ok("DBIx::SearchBuilder::Handle"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::mysql"); } my $h = DBIx::SearchBuilder::Handle::mysql->new(); is ($h->QuoteName('foo'), '`foo`', 'QuoteName works as expected'); is ($h->DequoteName('`foo`'), 'foo', 'DequoteName works as expected'); is ($h->DequoteName('`foo'), '`foo', 'DequoteName works as expected'); is ($h->DequoteName('foo`'), 'foo`', 'DequoteName works as expected'); is ($h->DequoteName('"foo"'), '"foo"', 'DequoteName works as expected'); DBIx-SearchBuilder-1.81/t/03rebless.t0000644000076500000240000000137514431214576016600 0ustar sunnavystaff#!/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.81/t/01records.t0000644000076500000240000002465614552307427016611 0ustar sunnavystaff#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 75; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { diag ("Running tests for $d"); 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 content)], "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(Content EmployeeId Name Phone id)], 'readable attributes' ); is_deeply( [sort($rec->WritableAttributes)], [qw(Content EmployeeId Name Phone)], 'writable attributes' ); can_ok($rec,'Create'); my ($id) = $rec->Create( Name => 'Jesse', Phone => '617 124 567', Content => 'Håvard'); 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"); is( $rec->Content, 'Håvard', "The record's Content is Håvard"); my ($val, $msg) = $rec->SetName('Obra'); ok($val, $msg) ; is($rec->Name, 'Obra', "We did actually change the name"); my $rec2 = TestApp::Address->new($handle); isa_ok($rec2, 'DBIx::SearchBuilder::Record'); my ($id2) = $rec2->Create( Name => 'Håvard', Phone => '617 124 567', Content => 'Foo'); ok($id2,"Created record ". $id2); ok($rec2->Load($id2), "Loaded the record"); is($rec2->id, $id2, "The record has its id"); is ($rec2->Name, 'Håvard', "The record's name is Håvard"); # 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'); # Confirm we truncate before comparing values and # don't try to update again with the same value ($val,$msg) = $rec->SetName('1234567890123456789012345678901234567890'); ok(!$val, $msg); is($msg, 'That is already the current value', 'No update for same value'); is($rec->Name, '12345678901234', "Value is the same"); # 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 => ''}, Content => {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'longblob', default => ''}, } } sub schema_mysql { < 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 { < 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 { < 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.81/t/02distinct_values.t0000644000076500000240000000774014552307427020344 0ustar sunnavystaff#!/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.81/t/11schema_records.t0000644000076500000240000002001514552307427020113 0ustar sunnavystaff#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 66; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { unless( has_schema( 'TestApp', $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); } ok( $phone3->Delete, "Deleted phone $p3_id" ); my $group = TestApp::Group->new($handle); my $g_id = $group->Create( Name => 'Employees' ); ok( $g_id, "Got an id for the new group: $g_id" ); $group->Load($g_id); is( $group->id, $g_id, "loaded group ok" ); 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) ) }, q{CREATE TABLE Groups ( id integer primary key, Name varchar(36) ) } ] } 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) ) }, q{CREATE TEMPORARY TABLE `Groups` ( id integer AUTO_INCREMENT primary key, Name varchar(36) ) } ] } sub schema_mariadb { [ 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) ) }, q{CREATE TEMPORARY TABLE `Groups` ( id integer AUTO_INCREMENT primary key, Name varchar(36) ) } ] } 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 ) }, q{CREATE TEMPORARY TABLE Groups ( id serial primary key, Name 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 ); } package TestApp::Group; use base $ENV{SB_TEST_CACHABLE}? qw/DBIx::SearchBuilder::Record::Cachable/: qw/DBIx::SearchBuilder::Record/; sub Table { 'Groups' } sub Schema { return { Name => { TYPE => 'varchar' }, } } package TestApp::GroupCollection; 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::Group'; return $class->new( $self->_Handle ); } 1; DBIx-SearchBuilder-1.81/t/03versions.t0000644000076500000240000000210614431214576017002 0ustar sunnavystaff#!/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.81/t/02records_cachable.t0000644000076500000240000000704714552307427020407 0ustar sunnavystaff#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 16; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; foreach my $d ( @AvailableDrivers ) { SKIP: { unless( has_schema( 'TestApp::Address', $d ) ) { skip "No schema for '$d' driver", TESTS_PER_DRIVER; } unless( should_test( $d ) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); my $ret = init_schema( 'TestApp::Address', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back"); my $rec = TestApp::Address->new($handle); isa_ok($rec, 'DBIx::SearchBuilder::Record'); my ($id) = $rec->Create( Name => 'Jesse', Phone => '617 124 567'); ok($id,"Created record #$id"); ok($rec->Load($id), "Loaded the record"); is($rec->id, $id, "The record has its id"); is($rec->Name, 'Jesse', "The record's name is Jesse"); my $rec_cache = TestApp::Address->new($handle); my ($status, $msg) = $rec_cache->LoadById($id); ok($status, 'loaded record'); is($rec_cache->id, $id, 'the same record as we created'); is($msg, 'Fetched from cache', 'we fetched record from cache'); DBIx::SearchBuilder::Record::Cachable->FlushCache; ok($rec->LoadByCols( Name => 'Jesse' ), "Loaded the record"); is($rec->id, $id, "The record has its id"); is($rec->Name, 'Jesse', "The record's name is Jesse"); $rec_cache = TestApp::Address->new($handle); ($status, $msg) = $rec_cache->LoadById($id); ok($status, 'loaded record'); is($rec_cache->id, $id, 'the same record as we created'); is($msg, 'Fetched from cache', 'we fetched record from cache'); cleanup_schema( 'TestApp::Address', $handle ); }} # SKIP, foreach blocks 1; package TestApp::Address; use base qw/DBIx::SearchBuilder::Record::Cachable/; sub _Init { my $self = shift; my $handle = shift; $self->Table('Address'); $self->_Handle($handle); } sub _ClassAccessible { return { id => {read => 1, type => 'int(11)', default => ''}, Name => {read => 1, write => 1, type => 'varchar(14)', default => ''}, Phone => {read => 1, write => 1, type => 'varchar(18)', length => 18, default => ''}, EmployeeId => {read => 1, write => 1, type => 'int(8)', default => ''}, } } sub _CacheConfig { return { 'cache_for_sec' => 60, }; } sub schema_mysql { < 17; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; my $handle; foreach my $d ( @AvailableDrivers ) { SKIP: { unless( has_schema( 'TestApp', $d ) ) { skip "No schema for '$d' driver", TESTS_PER_DRIVER; } unless( should_test( $d ) ) { skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER; } $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle->dbh, 'DBI::db'); diag "testing $d" if $ENV{'TEST_VERBOSE'}; my $ret = init_schema( 'TestApp', $handle ); isa_ok($ret,'DBI::st', "Inserted the schema. got a statement handle back"); my $count_all = init_data( 'TestApp::User', $handle ); ok( $count_all, "init users data" ); my $users = TestApp::Users->new( $handle ); $users->UnLimit; $users->Column( FIELD => 'Result' ); my $column = $users->Column( FUNCTION => $users->_Handle->DateTimeIntervalFunction( From => 'Created', To => 'Resolved' ), ); while ( my $user = $users->Next ) { if ( defined $user->Result ) { # Use an explicit numeric compare rather than 'is' to # work around values like 90061.000000 returned in Pg 14+ ok( $user->__Value($column) == $user->Result ); } else { ok( !defined $user->__Value($column) ); } } $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 ) { if ( defined $user->Result ) { # Use an explicit numeric compare rather than 'is' to # work around values like 90061.000000 returned in Pg 14+ ok( $user->__Value($column) == $user->Result ); } else { ok( !defined $user->__Value($column) ); } } 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.81/t/utils.pl0000644000076500000240000001171214552307427016304 0ustar sunnavystaff#!/usr/bin/perl -w use strict; use File::Temp qw/ tempdir /; use File::Spec; =head1 VARIABLES =head2 @SupportedDrivers Array of all supported DBD drivers. =cut our @SupportedDrivers = qw( Informix MariaDB mysql mysqlPP ODBC Oracle Pg SQLite Sybase ); =head2 @AvailableDrivers Array that lists only drivers from supported list that user has installed. =cut our @AvailableDrivers = grep { eval "require DBD::". $_ } @SupportedDrivers; =head1 FUNCTIONS =head2 get_handle Returns new DB specific handle. Takes one argument DB C<$type>. Other arguments uses to construct handle. =cut sub get_handle { my $type = shift; my $class = 'DBIx::SearchBuilder::Handle::'. $type; eval "require $class"; die $@ if $@; my $handle; $handle = $class->new( @_ ); return $handle; } =head2 handle_to_driver Returns driver name which gets from C<$handle> object argument. =cut sub handle_to_driver { my $driver = ref($_[0]); $driver =~ s/^.*:://; return $driver; } =head2 connect_handle Connects C<$handle> object to DB. =cut sub connect_handle { my $call = "connect_". lc handle_to_driver( $_[0] ); return unless defined &$call; goto &$call; } =head2 connect_handle_with_driver($handle, $driver) Connects C<$handle> using driver C<$driver>; can use this to test the magic that turns a C into a C on C. =cut sub connect_handle_with_driver { my $call = "connect_". lc $_[1]; return unless defined &$call; @_ = $_[0]; goto &$call; } sub connect_sqlite { my $dir = tempdir(CLEANUP => 1); my $handle = shift; return $handle->Connect( Driver => 'SQLite', Database => File::Spec->catfile($dir => "db.sqlite") ); } sub connect_mysql { my $handle = shift; return $handle->Connect( Driver => 'mysql', Database => $ENV{'SB_TEST_MYSQL'}, Host => $ENV{'SB_TEST_MYSQL_HOST'}, Port => $ENV{'SB_TEST_MYSQL_PORT'}, User => $ENV{'SB_TEST_MYSQL_USER'} || 'root', Password => $ENV{'SB_TEST_MYSQL_PASS'} || '', ); } sub connect_mariadb { my $handle = shift; return $handle->Connect( Driver => 'MariaDB', Database => $ENV{'SB_TEST_MARIADB'}, Host => $ENV{'SB_TEST_MARIADB_HOST'}, Port => $ENV{'SB_TEST_MARIADB_PORT'}, User => $ENV{'SB_TEST_MARIADB_USER'} || 'root', Password => $ENV{'SB_TEST_MARIADB_PASS'} || '', ); } sub connect_pg { my $handle = shift; return $handle->Connect( Driver => 'Pg', Database => $ENV{'SB_TEST_PG'}, Host => $ENV{'SB_TEST_PG_HOST'}, Port => $ENV{'SB_TEST_PG_PORT'}, 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.81/t/01searches.t0000644000076500000240000005273114552307427016740 0ustar sunnavystaff#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 153; 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); is($users_obj->Count, 2, 'user count on first page' ); { 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"; # Check SQL produced by QueryHint() and QueryHintFormatted() $users_obj->UnLimit; my $hintless_sql = $users_obj->BuildSelectQuery( PreferBind => 0 ); unlike( $hintless_sql, qr/\/\*/, "Query hint markers aren't present when QueryHint() isn't called" ); $users_obj->UnLimit; $users_obj->QueryHint( '+FooBar' ); my $hinted_sql = $users_obj->BuildSelectQuery( PreferBind => 0 ); like( $hinted_sql, qr|/\*\+FooBar \*/|, "..but are when QueryHint() IS called" ); 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.81/t/03searches_bind.t0000644000076500000240000002466514552307427017743 0ustar sunnavystaffuse strict; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 45; 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); local $DBIx::SearchBuilder::PREFER_BIND = 1; my $users_obj = $clean_obj->Clone; for my $login ( 'Gandalf', "Bilbo\\Baggins", "Baggins' Frodo" ) { $users_obj->Limit( FIELD => 'Login', VALUE => $login ); is( $users_obj->Count, 1, "only one value" ); is( $users_obj->First->Login, $login, "$login is the only match" ); # Using \W here because Login might be wrapped in LOWER(). ok( $users_obj->BuildSelectQuery =~ /Login\W*=\s*\?/i, 'found a placeholder in select query' ); ok( $users_obj->BuildSelectCountQuery =~ /Login\W*=\s*\?/i, 'found a placeholder in select count query' ); $users_obj->CleanSlate; } $users_obj->Limit( FIELD => 'Login', VALUE => [ "Bilbo\\Baggins", "Baggins' Frodo" ], OPERATOR => 'IN', ); is( $users_obj->Count, 2, "2 values" ); is_deeply( [ sort map { $_->Login } @{ $users_obj->ItemsArrayRef } ], [ "Baggins' Frodo", "Bilbo\\Baggins" ], '2 Baggins', ); $users_obj->OrderBy( FIELD => 'id', ORDER => 'ASC' ); $users_obj->RowsPerPage(1); is( $users_obj->First->Login, "Bilbo\\Baggins", "Bilbo\\Baggins on the first page" ); is( $users_obj->Count, 1, "1 value on the first page" ); ok( $users_obj->BuildSelectQuery =~ /LIMIT\s*\?|rownum\s*<=\s*\?.*limitrownum\s*>=\s*\?/i, 'found placeholders in limit in select query' ); $users_obj->GotoPage(1); is( $users_obj->First->Login, "Baggins' Frodo", "Baggins' Frodo on the second page" ); is( $users_obj->Count, 1, "1 value on the second page" ); ok( $users_obj->BuildSelectQuery =~ /LIMIT\s*\?,\s*\?|LIMIT\s*\? OFFSET|rownum\s*<=\s*\?.*limitrownum\s*>=\s*\?/i, 'found placeholders in limit in select query' ); $users_obj->CleanSlate; for my $name ( "Shire's Bag End", 'The Fellowship of the Ring' ) { my $groups_obj = TestApp::Groups->new($handle); $groups_obj->Limit( FIELD => 'Name', VALUE => $name, OPERATOR => 'LIKE' ); $groups_obj->Limit( FIELD => 'id', VALUE => 0, OPERATOR => '>' ); is( $groups_obj->Count, 1, "only one value" ); is( $groups_obj->First->Name, $name, "$name is the only match" ); # Using \W here because Login might be wrapped in LOWER(). ok( $groups_obj->BuildSelectQuery =~ /Name\W*I?LIKE\s*\?/i, 'found a placeholder for Name in select query' ); ok( $groups_obj->BuildSelectQuery =~ /id\s*>\s*\?/i, 'found a placeholder for id in select query' ); ok( $groups_obj->BuildSelectCountQuery =~ /Name\W*I?LIKE\s*\?/i, 'found a placeholder for Name in select count query' ); ok( $groups_obj->BuildSelectCountQuery =~ /id\s*>\s*\?/i, 'found a placeholder for id in select count query' ); } my $alias = $users_obj->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); my $group_alias = $users_obj->Join( ALIAS1 => $alias, FIELD1 => 'GroupID', ALIAS2 => $users_obj->NewAlias('Groups'), FIELD2 => 'id' ); $users_obj->Limit( LEFTJOIN => $group_alias, FIELD => 'Name', VALUE => "Shire's Bag End", ); is( $users_obj->Count, 2, "2 values" ); is_deeply( [ sort map { $_->Login } @{ $users_obj->ItemsArrayRef } ], [ "Baggins' Frodo", "Bilbo\\Baggins" ], '2 Baggins', ); # ? in JOIN condition ok( $users_obj->BuildSelectQuery( PreferBind => 0 ) !~ /\?/, 'found placeholder in select query' ); ok( $users_obj->BuildSelectCountQuery( PreferBind => 0 ) !~ /\?/, 'found placeholder in select count query' ); ok( $users_obj->BuildSelectQuery( PreferBind => 0 ) !~ /\?/, 'no placeholder in select query' ); ok( $users_obj->BuildSelectCountQuery( PreferBind => 0 ) !~ /\?/, 'no placeholder in select count query' ); $DBIx::SearchBuilder::PREFER_BIND = 0; ok( $users_obj->BuildSelectQuery !~ /\?/, 'no placeholder in select query' ); ok( $users_obj->BuildSelectCountQuery !~ /\?/, 'no placeholder in select count query' ); 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_mariadb { [ 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'], ['Gandalf'], ["Bilbo\\Baggins"], ["Baggins' Frodo"], ); } 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'], ["Shire's Bag End"], ['The Fellowship of the Ring'], ); } 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' ], # Shire [ 1, 2 ], [ 1, 3 ], # Fellowship of the Ring [ 2, 1 ], [ 2, 3 ], ); } 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.81/t/03cud_from_select.t0000644000076500000240000002110614552307427020272 0ustar sunnavystaff#!/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 $groups_table = ($d eq 'mysql') ? '`Groups`' : 'Groups'; 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_table 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_table 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", ] } # TEMPORARY tables can not be referenced more than once # in the same query, use real table for UsersToGroups sub schema_mariadb { [ 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_mariadb { [ "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.81/t/03searches_combine.t0000644000076500000240000002005114552307427020424 0ustar sunnavystaffuse strict; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 14; use version; 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); if ( !$handle->HasSupportForCombineSearchAndCount ) { skip "Database version doesn't support CombineSearchAndCount", 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_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 $users_obj = TestApp::Users->new($handle); $users_obj->CombineSearchAndCount(1); $users_obj->Limit( FIELD => 'Login', VALUE => 'Gandalf' ); is( $users_obj->Count, 1, 'only one value' ); is( $users_obj->CountAll, 1, 'only one value' ); is( $users_obj->First->Login, 'Gandalf', 'found Gandalf' ); $users_obj->CleanSlate; $users_obj->CombineSearchAndCount(1); $users_obj->Limit( FIELD => 'Login', VALUE => [ "Bilbo\\Baggins", "Baggins' Frodo" ], OPERATOR => 'IN', ); $users_obj->RowsPerPage(1); is( $users_obj->Count, 1, '1 value' ); is( $users_obj->CountAll, 2, '2 total values' ); $users_obj->OrderByCols( { FIELD => 'Login' } ); is_deeply( [ map { $_->Login } @{ $users_obj->ItemsArrayRef } ], [ "Baggins' Frodo" ], '1 Baggin', ); $users_obj->CleanSlate; $users_obj->CombineSearchAndCount(1); $users_obj->OrderByCols( { FIELD => 'Login' } ); my $alias = $users_obj->Join( FIELD1 => 'id', TABLE2 => 'UsersToGroups', FIELD2 => 'UserId' ); my $group_alias = $users_obj->Join( ALIAS1 => $alias, FIELD1 => 'GroupID', ALIAS2 => $users_obj->NewAlias('Groups'), FIELD2 => 'id' ); $users_obj->Limit( LEFTJOIN => $group_alias, FIELD => 'Name', VALUE => "Shire's Bag End", ); is( $users_obj->CountAll, 2, "2 total values" ); is( $users_obj->Count, 2, "2 values" ); is_deeply( [ sort map { $_->Login } @{ $users_obj->ItemsArrayRef } ], [ "Baggins' Frodo", "Bilbo\\Baggins" ], '2 Baggins', ); 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_mariadb { [ 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'], ['Gandalf'], ["Bilbo\\Baggins"], ["Baggins' Frodo"], ); } package TestApp::SearchBuilder; use base qw/DBIx::SearchBuilder/; sub BuildSelectQuery { die 'should not be called' } sub BuildSelectCountQuery { die 'should not be called' } 1; package TestApp::Users; use base qw/TestApp::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'], ["Shire's Bag End"], ['The Fellowship of the Ring'], ); } package TestApp::Groups; use base qw/TestApp::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' ], # Shire [ 1, 2 ], [ 1, 3 ], # Fellowship of the Ring [ 2, 1 ], [ 2, 3 ], ); } package TestApp::UsersToGroups; use base qw/TestApp::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.81/t/testmodels.pl0000644000076500000240000000131414370111525017312 0ustar sunnavystaffpackage 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.81/t/00.load.t0000644000076500000240000000153214552307427016130 0ustar sunnavystaffuse Test::More tests => 13; 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"); } BEGIN { use_ok("DBIx::SearchBuilder::Handle::MariaDB"); } DBIx-SearchBuilder-1.81/t/10schema.t0000644000076500000240000000553514431214576016401 0ustar sunnavystaff#!/usr/bin/perl use strict; use warnings; use Test::More; use constant TESTS_PER_DRIVER => 14; our @AvailableDrivers; BEGIN { require("./t/utils.pl"); my $total = 3 + scalar(@AvailableDrivers) * TESTS_PER_DRIVER; if( not eval { require DBIx::DBSchema } ) { plan skip_all => "DBIx::DBSchema not installed"; } else { plan tests => $total; } } BEGIN { use_ok("DBIx::SearchBuilder::SchemaGenerator"); use_ok("DBIx::SearchBuilder::Handle"); } require_ok("./t/testmodels.pl"); foreach my $d ( @AvailableDrivers ) { SKIP: { unless ($d eq 'Pg') { skip "first goal is to work on Pg", TESTS_PER_DRIVER; } unless( should_test( $d ) ) { skip "ENV is not defined for driver $d", TESTS_PER_DRIVER; } my $handle = get_handle( $d ); connect_handle( $handle ); isa_ok($handle, "DBIx::SearchBuilder::Handle::$d"); isa_ok($handle->dbh, 'DBI::db'); my $SG = DBIx::SearchBuilder::SchemaGenerator->new($handle); isa_ok($SG, 'DBIx::SearchBuilder::SchemaGenerator'); isa_ok($SG->_db_schema, 'DBIx::DBSchema'); is($SG->CreateTableSQLText, '', "no tables means no sql"); my $ret = $SG->AddModel('Sample::This::Does::Not::Exist'); ok($ret == 0, "couldn't add model from nonexistent class"); like($ret->error_message, qr/Error making new object from Sample::This::Does::Not::Exist/, "couldn't add model from nonexistent class"); is($SG->CreateTableSQLText, '', "no tables means no sql"); $ret = $SG->AddModel('Sample::Address'); ok($ret != 0, "added model from real class"); is_ignoring_space($SG->CreateTableSQLText, <new; isa_ok($employee, 'Sample::Employee'); $ret = $SG->AddModel($employee); ok($ret != 0, "added model from an instantiated object"); is_ignoring_space($SG->CreateTableSQLText, <CreateTableSQLStatements; is_ignoring_space($SG->CreateTableSQLText, $manually_make_text, 'CreateTableSQLText is the statements in CreateTableSQLStatements') }} sub is_ignoring_space { my $a = shift; my $b = shift; $a =~ s/^\s+//; $a =~ s/\s+$//; $a =~ s/\s+/ /g; $b =~ s/^\s+//; $b =~ s/\s+$//; $b =~ s/\s+/ /g; unshift @_, $b; unshift @_, $a; goto &is; } DBIx-SearchBuilder-1.81/t/03transactions.t0000644000076500000240000001544014552307427017651 0ustar sunnavystaff#!/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 { < 19; 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', ); } diag "CAST FUNCTION in Column" if $ENV{'TEST_VERBOSE'}; { my $users_obj = $clean_obj->Clone; $users_obj->UnLimit; $users_obj->OrderByCols( { FIELD => $handle->CastAsDecimal('DeptNumber') } ); $users_obj->Column(FIELD => 'DeptNumber'); is_deeply( [ map $_->DeptNumber, @{ $users_obj->ItemsArrayRef } ], [ 2, 5, 30, 100 ], '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), DeptNumber 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), DeptNumber 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_mariadb { [ q{ CREATE TEMPORARY TABLE Users ( id integer primary key AUTO_INCREMENT, Login varchar(36), DeptNumber 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), DeptNumber 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), DeptNumber 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)'}, DeptNumber => {read => 1, write => 1, type => 'varchar(36)'}, } } sub init_data { return ( [ 'Login', 'DeptNumber' ], [ 'Ivan', '30' ], [ 'john', '100' ], [ 'Bob', '5' ], [ 'aurelia', '2' ], ); } 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.81/t/02records_datetime.t0000644000076500000240000002227314552307427020457 0ustar sunnavystaff#!/usr/bin/perl -w BEGIN { $ENV{'TZ'} = 'Europe/Moscow' }; use strict; use warnings; use Test::More; BEGIN { require "./t/utils.pl" } our (@AvailableDrivers); use constant TESTS_PER_DRIVER => 38; my $total = scalar(@AvailableDrivers) * TESTS_PER_DRIVER; plan tests => $total; my $handle; 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' || $d eq 'MariaDB' ) { 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.81/t/02searches_joins.t0000644000076500000240000003501714552307427020141 0ustar sunnavystaff#!/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_mariadb { [ 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.81/README0000644000076500000240000005407514552307762015237 0ustar sunnavystaffNAME DBIx::SearchBuilder - Encapsulate SQL queries and rows in simple perl objects 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(); } 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 "DBIx::SearchBuilder" and a subclass of "DBIx::SearchBuilder::Record" for each table that you wish to access. (See the documentation of "DBIx::SearchBuilder::Record" for more information on subclassing it.) Your "DBIx::SearchBuilder" subclass must override "NewItem", and probably should override at least "_Init" also; at the very least, "_Init" should probably call "_Handle" and "_Table" to set the database handle (a "DBIx::SearchBuilder::Handle" 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. METHOD NAMING Each method has a lower case alias; '_' is used to separate words. For example, the method "RedoSearch" has the alias "redo_search". METHODS new Creates a new SearchBuilder object and immediately calls "_Init" with the same parameters that were passed to "new". If you haven't overridden "_Init" in your subclass, this means that you should pass in a "DBIx::SearchBuilder::Handle" (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 "_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. _Init This method is called by "new" with whatever arguments were passed to "new". By default, it takes a "DBIx::SearchBuilder::Handle" object as a "Handle" argument, although this is not necessary if your subclass overrides "_Handle". 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. Clone Returns copy of the current object with all search restrictions. _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. _Handle [DBH] Get or set this object's DBIx::SearchBuilder::Handle object. _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 "Next"). AddRecord RECORD Adds a record object to this collection. _RecordCount This private internal method returns the number of Record objects saved as a result of the last query. _DoCount This internal private method actually executes a counting operation on the database; it is used by "Count" and "CountAll". _DoSearchAndCount This internal private method actually executes the search and also counting on the database; _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 "$self->RowsPerPage" rows, skipping "$self->FirstRow" rows. (That is, if rows are numbered starting from 0, row number "$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 "OrderByCols", say). _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. _DistinctQueryAndCount STATEMENTREF This routine takes a reference to a scalar containing an SQL statement. It massages the statement to ensure a distinct result set and total number of potential records are returned. _BuildJoins Build up all of the joins we need to perform this query. _isJoined Returns true if this SearchBuilder will be joining multiple tables together. _isLimited If we've limited down this search, return true. Otherwise, return false. BuildSelectQuery PreferBind => 1|0 Builds a query string for a "SELECT rows from Tables" statement for this SearchBuilder object If "PreferBind" is true, the generated query will use bind variables where possible. If "PreferBind" is not passed, it defaults to package variable $DBIx::SearchBuilder::PREFER_BIND, which defaults to $ENV{SB_PREFER_BIND}. To override global $DBIx::SearchBuilder::PREFER_BIND for current object only, you can also set "_prefer_bind" accordingly, e.g. $sb->{_prefer_bind} = 1; BuildSelectCountQuery PreferBind => 1|0 Builds a SELECT statement to find the number of rows this SearchBuilder object would find. BuildSelectAndCountQuery PreferBind => 1|0 Builds a query string that is a combination of BuildSelectQuery and BuildSelectCountQuery. 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. 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. GotoItem Takes an integer N and sets the record iterator to N. The first time "Next" 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 "ItemsArrayRef"). If GotoItem is called before the search query is ever run, it will reset the item iterator and "Next" will return the "First" item. First Returns the first item Last Returns the last item DistinctFieldValues Returns list with distinct values of field. Limits on collection are accounted, so collection should be "UnLimit"ed to get values from the whole table. Takes paramhash with the following keys: Field Field name. Can be first argument without key. Order 'ASC', 'DESC' or undef. Defines whether results should be sorted or not. By default results are not sorted. Max Maximum number of elements to fetch. ItemsArrayRef Return a reference to an array containing all objects found by this search. NewItem NewItem must be subclassed. It is used by DBIx::SearchBuilder to create record objects for each row returned from the database. RedoSearch Takes no arguments. Tells DBIx::SearchBuilder that the next time it's asked for a record, it should requery the database CombineSearchAndCount 1|0 Tells DBIx::SearchBuilder if it shall search both records and the total count in a single query. UnLimit UnLimit clears all restrictions and causes this object to return all rows in the primary table. Limit Limit takes a hash of parameters with the following keys: 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). 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. 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. ) FIELD Column to be checked against. FUNCTION Function that should be checked against or applied to the FIELD before check. See "CombineFunctionWithField" for rules. VALUE Should always be set and will always be quoted. OPERATOR OPERATOR is the SQL operator to use for this phrase. Possible choices include: "=" "!=" "LIKE" In the case of LIKE, the string is surrounded in % signs. Yes. this is a bug. "NOT LIKE" "STARTSWITH" STARTSWITH is like LIKE, except it only appends a % at the end of the string "ENDSWITH" ENDSWITH is like LIKE, except it prepends a % to the beginning of the string "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. "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 "Column" is selected then "id" is used, if more than one selected then warning is issued and first column is used. ENTRYAGGREGATOR Can be "AND" or "OR" (or anything else valid to aggregate two clauses in SQL). Special value is "none" which means that no entry aggregator should be used. The default value is "OR". CASESENSITIVE on some databases, such as postgres, setting CASESENSITIVE to 1 will make this search case sensitive 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 statements 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'); OrderBy PARAMHASH Orders the returned results by ALIAS.FIELD ORDER. Takes a paramhash of ALIAS, FIELD and ORDER. ALIAS defaults to "main". FIELD has no default value. ORDER defaults to ASC(ending). DESC(ending) is also a valid value for OrderBy. FIELD also accepts FUNCTION(FIELD) format. 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. _OrderClause returns the ORDER BY clause for the search. GroupByCols ARRAY_OF_HASHES Each hash contains the keys FIELD, FUNCTION and ALIAS. Hash combined into SQL with "CombineFunctionWithField". _GroupClause Private function to return the "GROUP BY" clause for this query. NewAlias Takes the name of a table and paramhash with TYPE and DISTINCT. Use TYPE equal to "LEFT" to indicate that it's LEFT JOIN. Old style way to call (see below) is also supported, but should be avoided: $records->NewAlias('aTable', 'left'); True DISTINCT value indicates that this join keeps result set distinct and DB side distinct is not required. See also "Join". 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. 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 DBIx::SearchBuilder 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 "_DistinctQuery" call that can hurt performance of the query. See also "NewAlias". Pages: size and changing Use "RowsPerPage" to set size of pages. "NextPage", "PrevPage", "FirstPage" or "GotoPage" to change pages. "FirstRow" to do tricky stuff. 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. NextPage Turns one page forward. PrevPage Turns one page backwards. FirstPage Jumps to the first page. GotoPage Takes an integer number and jumps to that page or first page if number omitted. Numbering starts from zero. 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 "RowsPerPage", "NextPage" and other methods to walk pages. It only may be helpful to get 10 records starting from 5th. _ItemsCounter Returns the current position in the record set. Count Returns the number of records in the set. When "RowsPerPage" is set, returns number of records in the page only, otherwise the same as "CountAll". CountAll Returns the total number of potential records in the set, ignoring any "RowsPerPage" settings. IsLast Returns true if the current row is the last record in the set. 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: FIELD Column name to fetch or apply function to. ALIAS Alias of a table the field is in; defaults to "main" FUNCTION A SQL function that should be selected instead of FIELD or applied to it. AS The column 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 "undef" to skip column aliasing entirely. "FIELD", "ALIAS" and "FUNCTION" are combined according to "CombineFunctionWithField". 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 "_Value" in DBIx::SearchBuilder::Record 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. CombineFunctionWithField Takes a hash with three optional arguments: FUNCTION, FIELD and ALIAS. Returns SQL with all three arguments combined according to the following rules. * FUNCTION or undef returned when FIELD is not provided * 'main' ALIAS is used if not provided * ALIAS.FIELD returned when FUNCTION is not provided * NULL returned if FUNCTION is 'NULL' * If FUNCTION contains '?' (question marks) then they are replaced with ALIAS.FIELD and result returned. * If FUNCTION has no '(' (opening parenthesis) then ALIAS.FIELD is appended in parentheses and returned. 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' Columns LIST Specify that we want to load only the columns in LIST AdditionalColumn Calls "Column", 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 "Column". Returns the result of calling "Column". Fields TABLE Return a list of fields in TABLE. These fields are in the case presented by the database, which may be case-sensitive. HasField { TABLE => undef, FIELD => undef } Returns true if TABLE has field FIELD. Return false otherwise Note: Both TABLE and FIELD are case-sensitive (See: "Fields") Table [TABLE] If called with an argument, sets this collection's table. Always returns this collection's table. QueryHint [Hint] If called with an argument, sets a query hint for this collection. Call this method before performing additional operations on a collection, such as Count(), Next(), etc. Always returns the query hint. When the query hint is included in the SQL query, the "/* ... */" will be included for you. Here's an example query hint for Oracle: $sb->QueryHint("+CURSOR_SHARING_EXACT"); QueryHintFormatted Returns the query hint formatted appropriately for inclusion in SQL queries. DEPRECATED METHODS GroupBy DEPRECATED. Alias for the "GroupByCols" method. SetTable DEPRECATED. Alias for the "Table" method. ShowRestrictions DEPRECATED AND DOES NOTHING. ImportRestrictions DEPRECATED AND DOES NOTHING. TESTING In order to test most of the features of "DBIx::SearchBuilder", you need to provide "make test" with a test database. For each DBI driver that you would like to test, set the environment variables "SB_TEST_FOO", "SB_TEST_FOO_USER", and "SB_TEST_FOO_PASS" to a database name, database username, and database password, where "FOO" is the driver name in all uppercase. You can test as many drivers as you like. (The appropriate "DBD::" module needs to be installed in order for the test to work.) Note that the "SQLite" driver will automatically be tested if "DBD::Sqlite" is installed, using a temporary file as the database. For example: SB_TEST_MYSQL=test SB_TEST_MYSQL_USER=root SB_TEST_MYSQL_PASS=foo \ SB_TEST_PG=test SB_TEST_PG_USER=postgres make test AUTHOR Best Practical Solutions, LLC CONTRIBUTORS Ansgar Burchardt Audrey Tang Ivan Kohler Martin King Mathieu Arnold Matt Knopp Matthew Simon Cavalletto Nick Morrott Oliver Tappe Simon Cozens BUGS All bugs should be reported via email to L or via the web at L. LICENSE AND COPYRIGHT Copyright (C) 2001-2024, Best Practical Solutions LLC. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. SEE ALSO DBIx::SearchBuilder::Handle, DBIx::SearchBuilder::Record. DBIx-SearchBuilder-1.81/.gitignore0000644000076500000240000000013014370111524016311 0ustar sunnavystaffMakefile Makefile.bak Makefile.old MANIFEST.old MANIFEST.bak pm_to_blib blib/ MYMETA.* DBIx-SearchBuilder-1.81/META.yml0000644000076500000240000000151414552307763015617 0ustar sunnavystaff--- abstract: 'Encapsulate SQL queries and rows in simple perl objects' author: - 'Best Practical Solutions, LLC ' build_requires: DBD::SQLite: 1.6 ExtUtils::MakeMaker: 6.59 File::Temp: 0 Test::More: 0.52 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.21' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: DBIx-SearchBuilder no_index: directory: - ex - inc - t requires: Cache::Simple::TimedExpiry: '0.21' Class::Accessor: 0 Class::ReturnValue: 0.4 Clone: 0 DBI: 0 DBIx::DBSchema: 0 Encode: '1.99' Scalar::Util: 0 Want: 0 capitalization: '0.03' perl: 5.10.1 resources: license: http://dev.perl.org/licenses/ version: '1.81' DBIx-SearchBuilder-1.81/lib/0000755000076500000240000000000014552307764015114 5ustar sunnavystaffDBIx-SearchBuilder-1.81/lib/DBIx/0000755000076500000240000000000014552307764015702 5ustar sunnavystaffDBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/0000755000076500000240000000000014552307764020416 5ustar sunnavystaffDBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Record/0000755000076500000240000000000014552307764021634 5ustar sunnavystaffDBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Record/Cachable.pm0000755000076500000240000001537314431214576023662 0ustar sunnavystaffpackage 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_for_sec' => 5, }; } 1; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/0000755000076500000240000000000014552307764021611 5ustar sunnavystaffDBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/ODBC.pm0000644000076500000240000000277514431214576022663 0ustar sunnavystaffpackage 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; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/Pg.pm0000755000076500000240000002224214431214576022514 0ustar sunnavystaffpackage 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 BuildDSN Extend L to force C to be UTF-8, so that character strings can be safely passed to, and retrieved from, the database. See L. =cut sub BuildDSN { my $self = shift; $self->SUPER::BuildDSN(@_); $self->{'dsn'} .= ';client_encoding=UTF8'; return $self->{'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. 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}); # Let's 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 $sb = shift; my $limit_clause = ''; if ( $per_page) { $limit_clause = " LIMIT "; if ( $sb->{_bind_values} ) { push @{ $sb->{_bind_values} }, $per_page, $first || (); $first = '?' if $first; $per_page = '?'; } $limit_clause .= $per_page; if ( $first ) { $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 !~ /(?DatabaseVersion =~ /^(\d+)\.(\d+)/ and ($1 > 9 or ($1 == 9 and $2 >= 1))) { # Pg 9.1 supports "SELECT main.foo ... GROUP BY main.id" if id is the primary key $groups = [ {FIELD => "id"} ]; } else { # For earlier versions, we have to list out all of the columns $groups = [ map {+{FIELD => $_}} $self->Fields($table) ]; } local $sb->{group_by} = $groups; 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; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/Sybase.pm0000644000076500000240000000535214536152674023402 0ustar sunnavystaffpackage 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; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/SQLite.pm0000644000076500000240000001233314431214576023304 0ustar sunnavystaff 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; my $sb = 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; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/Informix.pm0000644000076500000240000000612514431214576023740 0ustar sunnavystaffpackage 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; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/MariaDB.pm0000755000076500000240000002462714552307427023420 0ustar sunnavystaffpackage DBIx::SearchBuilder::Handle::MariaDB; use strict; use warnings; use version; use base qw(DBIx::SearchBuilder::Handle); =head1 NAME DBIx::SearchBuilder::Handle::MariaDB - A MariaDB 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); } # Follow the advice in the docs and use last_insert_id rather than # {'mariadb_insertid'}. # # https://metacpan.org/dist/DBD-MariaDB/view/lib/DBD/MariaDB.pod#mariadb_insertid $self->{'id'} = $self->dbh->last_insert_id(); # Docs say last_insert_id could still return undef, so keeping this code 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 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. =cut sub BLOBParams { my $self = shift; my $field = shift; my $type = shift; if ( $type =~ /^(blob|longblob)$/i ) { # Don't assign to key 'value' as it is defined later. return ( { TYPE => 'SQL_BLOB', } ); } else { # Normal handling for these, so no hashref return; } } =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}; } $table = $self->QuoteName($table) if $self->{'QuoteTableNames'}; 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; $table = $self->QuoteName($table) if $self->{'QuoteTableNames'}; 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 MariaDB 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 MariaDB'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 MariaDB config }; } =head2 ConvertTimezoneFunction Custom implementation of L. Use the following query to get list of timezones: SELECT Name FROM mysql.time_zone_name; See also details on how MariaDB works with mysql timezone tables https://mariadb.com/kb/en/time-zones/ =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'})"; } =head2 QuoteName Quote table or column name to avoid reserved word errors. =cut # over-rides inherited method sub QuoteName { my ($self, $name) = @_; # use dbi built in quoting if we have a connection, if ($self->dbh) { return $self->SUPER::QuoteName($name); } return sprintf('`%s`', $name); } sub DequoteName { my ($self, $name) = @_; # If we have a handle, the base class can do it for us if ($self->dbh) { return $self->SUPER::DequoteName($name); } if ($name =~ /^`(.*)`$/) { return $1; } return $name; } sub _ExtractBindValues { my $self = shift; my $value = shift; return $self->SUPER::_ExtractBindValues( $value, '\\' ); } sub _IsMariaDB { my $self = shift; # We override DatabaseVersion to chop off "-MariaDB-whatever", so # call super here to get the original version my $v = $self->SUPER::DatabaseVersion(); return ($v =~ /mariadb/i); } sub _RequireQuotedTables { my $self = shift; # MariaDB version does not match mysql, and hasn't added new reserved words # like "groups". return 0; } =head2 HasSupportForCombineSearchAndCount MariaDB 10.2+ supports this. =cut sub HasSupportForCombineSearchAndCount { my $self = shift; my ($version) = $self->DatabaseVersion =~ /^(\d+\.\d+)/; return (version->parse('v'.$version) >= version->parse('v10.2')) ? 1 : 0; } sub CastAsDecimal { my $self = shift; my $field = shift or return; # CAST($field AS DECIMAL) rounds values to integers by default. It supports # specific precisions like CAST($field AS DECIMAL(5,2)), but we don't know # the precisions in advance. +0 works like other dbs. return "($field+0)"; } 1; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/Oracle.pm0000755000076500000240000002737214536333330023360 0ustar sunnavystaffpackage 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; my $sb = 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 my $last = $first + $per_page - 1; if ( $sb->{_bind_values} ) { push @{ $sb->{_bind_values} }, $last, $first; $first = $last = '?'; } $$statementref = "SELECT * FROM ( SELECT limitquery.*,rownum limitrownum FROM ( $$statementref ) limitquery WHERE rownum <= " . $last . " ) 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; my $hint = $sb->QueryHint; $hint = $hint ? " /* $hint */ " : " "; 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" . $hint . "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" . $hint . " 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; } sub CastAsDecimal { my $self = shift; my $field = shift or return; return "TO_NUMBER($field)"; } 1; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/mysql.pm0000755000076500000240000002352714536333330023316 0ustar sunnavystaffpackage DBIx::SearchBuilder::Handle::mysql; use strict; use warnings; use version; 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}; } $table = $self->QuoteName($table) if $self->{'QuoteTableNames'}; 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; $table = $self->QuoteName($table) if $self->{'QuoteTableNames'}; 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'})"; } =head2 QuoteName Quote table or column name to avoid reserved word errors. =cut # over-rides inherited method sub QuoteName { my ($self, $name) = @_; # use dbi built in quoting if we have a connection, if ($self->dbh) { return $self->SUPER::QuoteName($name); } return sprintf('`%s`', $name); } sub DequoteName { my ($self, $name) = @_; # If we have a handle, the base class can do it for us if ($self->dbh) { return $self->SUPER::DequoteName($name); } if ($name =~ /^`(.*)`$/) { return $1; } return $name; } sub _ExtractBindValues { my $self = shift; my $value = shift; return $self->SUPER::_ExtractBindValues( $value, '\\' ); } sub _IsMariaDB { my $self = shift; # We override DatabaseVersion to chop off "-MariaDB-whatever", so # call super here to get the original version my $v = $self->SUPER::DatabaseVersion(); return ($v =~ /mariadb/i); } sub _RequireQuotedTables { my $self = shift; # MariaDB version does not match mysql, and hasn't added new reserved words return 0 if $self->_IsMariaDB; my $version = $self->DatabaseVersion; # Get major version number by chopping off everything after the first "." $version =~ s/\..*//; if ( $version >= 8 ) { return 1; } return 0; } =head2 HasSupportForCombineSearchAndCount MariaDB 10.2+ and MySQL 8+ support this. =cut sub HasSupportForCombineSearchAndCount { my $self = shift; my ($version) = $self->DatabaseVersion =~ /^(\d+\.\d+)/; if ( $self->_IsMariaDB ) { return (version->parse('v'.$version) >= version->parse('v10.2')) ? 1 : 0; } else { return (version->parse('v'.$version) >= version->parse('v8')) ? 1 : 0; } } sub CastAsDecimal { my $self = shift; my $field = shift or return; # CAST($field AS DECIMAL) rounds values to integers by default. It supports # specific precisions like CAST($field AS DECIMAL(5,2)), but we don't know # the precisions in advance. +0 works like other dbs. return "($field+0)"; } 1; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Handle/mysqlPP.pm0000644000076500000240000000057414431214576023554 0ustar sunnavystaffpackage 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. DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Unique.pm0000644000076500000240000000266014431214576022220 0ustar sunnavystaffpackage 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 QuoteTableNames Returns 1 if table names will be quoted in queries, otherwise 0 =cut sub QuoteTableNames { return shift->{'QuoteTableNames'} } =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 an error occurred. =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 $sb = shift; my $limit_clause = ''; if ( $per_page) { $limit_clause = " LIMIT "; if ( $sb->{_bind_values} ) { push @{$sb->{_bind_values}}, $first || (), $per_page; $first = '?' if $first; $per_page = '?'; } 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; $args{'TABLE2'} = $self->DequoteName($args{'TABLE2'}) if $self->QuoteTableNames; } 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; $args{'TABLE2'} = $self->DequoteName($args{'TABLE2'}) if $self->QuoteTableNames; } 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'} ); } $args{TABLE2} = $self->QuoteName($args{TABLE2}) if $self->QuoteTableNames; 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"} ||= {}; $args{TABLE2} = $self->QuoteName($args{TABLE2}) if $self->QuoteTableNames; $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 $table = $self->{'QuoteTableNames'} ? $self->QuoteName($sb->Table) : $sb->Table; my $join_clause = join " CROSS JOIN ", ("$table main"), @{ $sb->{'aliases'} }; my %processed = map { /^\S+\s+(\S+)$/; $1 => 1 } @{ $sb->{'aliases'} }; $processed{'main'} = 1; # get a @list of joins that have not been processed yet, but depend on processed join my $joins = $sb->{'left_joins'}; while ( my @list = grep !$processed{ $_ } && (!$joins->{ $_ }{'depends_on'} || $processed{ $joins->{ $_ }{'depends_on'} }), sort keys %$joins ) { foreach my $join ( @list ) { $processed{ $join }++; my $meta = $joins->{ $join }; my $aggregator = $meta->{'entry_aggregator'} || 'AND'; $join_clause .= $meta->{'alias_string'} . " ON "; my @tmp = map { ref($_)? $_->{'field'} .' '. $_->{'op'} .' '. $_->{'value'}: $_ } map { ('(', @$_, ')', $aggregator) } sorted_values($meta->{'criteria'}); pop @tmp; $join_clause .= join ' ', @tmp; } } # here we could check if there is recursion in joins by checking that all joins # are processed if ( my @not_processed = grep !$processed{ $_ }, keys %$joins ) { die "Unsatisfied dependency chain in joins @not_processed"; } return $join_clause; } sub OptimizeJoins { my $self = shift; my %args = (SearchBuilder => undef, @_); my $joins = $args{'SearchBuilder'}->{'left_joins'}; my %processed = map { /^\S+\s+(\S+)$/; $1 => 1 } @{ $args{'SearchBuilder'}->{'aliases'} }; $processed{ $_ }++ foreach grep $joins->{ $_ }{'type'} ne 'LEFT', keys %$joins; $processed{'main'}++; my @ordered; # get a @list of joins that have not been processed yet, but depend on processed join # if we are talking about forest then we'll get the second level of the forest, # but we should process nodes on this level at the end, so we build FILO ordered list. # finally we'll get ordered list with leafes in the beginning and top most nodes at # the end. while ( my @list = grep !$processed{ $_ } && $processed{ $joins->{ $_ }{'depends_on'} }, sort keys %$joins ) { unshift @ordered, @list; $processed{ $_ }++ foreach @list; } foreach my $join ( @ordered ) { next if $self->MayBeNull( SearchBuilder => $args{'SearchBuilder'}, ALIAS => $join ); $joins->{ $join }{'alias_string'} =~ s/^\s*LEFT\s+/ /; $joins->{ $join }{'type'} = 'NORMAL'; } # here we could check if there is recursion in joins by checking that all joins # are processed } =head2 MayBeNull Takes a C and C in a hash and resturns true if restrictions of the query allow NULLs in a table joined with the ALIAS, otherwise returns false value which means that you can use normal join instead of left for the aliased table. Works only for queries have been built with L and L methods, for other cases return true value to avoid fault optimizations. =cut sub MayBeNull { my $self = shift; my %args = (SearchBuilder => undef, ALIAS => undef, @_); # if we have at least one subclause that is not generic then we should get out # of here as we can't parse subclauses return 1 if grep $_ ne 'generic_restrictions', keys %{ $args{'SearchBuilder'}->{'subclauses'} }; # build full list of generic conditions my @conditions; foreach ( grep @$_, sorted_values($args{'SearchBuilder'}->{'restrictions'}) ) { push @conditions, 'AND' if @conditions; push @conditions, '(', @$_, ')'; } # find tables that depends on this alias and add their join conditions foreach my $join ( sorted_values($args{'SearchBuilder'}->{'left_joins'}) ) { # left joins on the left side so later we'll get 1 AND x expression # which equal to x, so we just skip it next if $join->{'type'} eq 'LEFT'; next unless $join->{'depends_on'} eq $args{'ALIAS'}; my @tmp = map { ('(', @$_, ')', $join->{'entry_aggregator'}) } sorted_values($join->{'criteria'}); pop @tmp; @conditions = ('(', @conditions, ')', 'AND', '(', @tmp ,')'); } return 1 unless @conditions; # replace conditions with boolean result: 1 - allows nulls, 0 - not # all restrictions on that don't act on required alias allow nulls # otherwise only IS NULL operator foreach ( splice @conditions ) { unless ( ref $_ ) { push @conditions, $_; } elsif ( rindex( $_->{'field'}, "$args{'ALIAS'}.", 0 ) == 0 ) { # field is alias.xxx op ... and only IS op allows NULLs push @conditions, lc $_->{op} eq 'is'; } elsif ( $_->{'value'} && rindex( $_->{'value'}, "$args{'ALIAS'}.", 0 ) == 0 ) { # value is alias.xxx so it can not be IS op push @conditions, 0; } elsif ( $_->{'field'} =~ /^(?i:lower)\(\s*\Q$args{'ALIAS'}\./ ) { # handle 'LOWER(alias.xxx) OP VALUE' we use for case insensetive push @conditions, lc $_->{op} eq 'is'; } else { push @conditions, 1; } } # resturns index of closing paren by index of openning paren my $closing_paren = sub { my $i = shift; my $count = 0; for ( ; $i < @conditions; $i++ ) { if ( $conditions[$i] eq '(' ) { $count++; } elsif ( $conditions[$i] eq ')' ) { $count--; } return $i unless $count; } die "lost in parens"; }; # solve boolean expression we have, an answer is our result my $parens_count = 0; my @tmp = (); while ( defined ( my $e = shift @conditions ) ) { #print "@tmp >>>$e<<< @conditions\n"; return $e if !@conditions && !@tmp; unless ( $e ) { if ( $conditions[0] eq ')' ) { push @tmp, $e; next; } my $aggreg = uc shift @conditions; if ( $aggreg eq 'OR' ) { # 0 OR x == x next; } elsif ( $aggreg eq 'AND' ) { # 0 AND x == 0 my $close_p = $closing_paren->(0); splice @conditions, 0, $close_p + 1, (0); } else { die "unknown aggregator: @tmp $e >>>$aggreg<<< @conditions"; } } elsif ( $e eq '1' ) { if ( $conditions[0] eq ')' ) { push @tmp, $e; next; } my $aggreg = uc shift @conditions; if ( $aggreg eq 'OR' ) { # 1 OR x == 1 my $close_p = $closing_paren->(0); splice @conditions, 0, $close_p + 1, (1); } elsif ( $aggreg eq 'AND' ) { # 1 AND x == x next; } else { die "unknown aggregator: @tmp $e >>>$aggreg<<< @conditions"; } } elsif ( $e eq '(' ) { if ( $conditions[1] eq ')' ) { splice @conditions, 1, 1; } else { $parens_count++; push @tmp, $e; } } elsif ( $e eq ')' ) { die "extra closing paren: @tmp >>>$e<<< @conditions" if --$parens_count < 0; unshift @conditions, @tmp, $e; @tmp = (); } else { die "lost: @tmp >>>$e<<< @conditions"; } } return 1; } =head2 DistinctQuery STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctQuery { my $self = shift; my $statementref = shift; my $sb = shift; my %args = ( Wrap => 0, @_ ); my $QueryHint = $sb->QueryHint; $QueryHint = $QueryHint ? " /* $QueryHint */ " : " "; # Prepend select query for DBs which allow DISTINCT on all column types. $$statementref = "SELECT" . $QueryHint . "DISTINCT main.* FROM $$statementref"; $$statementref .= $sb->_GroupClause; if ( $args{'Wrap'} ) { $$statementref = "SELECT * FROM ($$statementref) main"; } $$statementref .= $sb->_OrderClause; } =head2 DistinctQueryAndCount STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set and the total count of potential records. =cut sub DistinctQueryAndCount { my $self = shift; my $statementref = shift; my $sb = shift; # order by clause should be on outer most query # SQL standard: ORDER BY command cannot be used in a Subquery # mariadb explanation: https://mariadb.com/kb/en/why-is-order-by-in-a-from-subquery-ignored/ # pg: actually keeps order of a subquery as long as some conditions in outer query are met, but # it's just a coincidence, not a feature # SQL server: https://learn.microsoft.com/en-us/sql/t-sql/queries/select-order-by-clause-transact-sql?view=sql-server-ver16 # The ORDER BY clause is not valid in views, ... and *subqueries*, unless ... my $order = $sb->_OrderClause; my $wrap = $order !~ /(?DistinctQuery($statementref, $sb, Wrap => $wrap); # DistinctQuery already has an outer SELECT, which we can reuse $$statementref =~ s!(?= FROM)!, COUNT(main.id) OVER() AS search_builder_count_all!; } =head2 DistinctCount STATEMENTREF takes an incomplete SQL SELECT statement and massages it to return a DISTINCT result set. =cut sub DistinctCount { my $self = shift; my $statementref = shift; my $sb = shift; my $QueryHint = $sb->QueryHint; $QueryHint = $QueryHint ? " /* $QueryHint */ " : " "; # Prepend select query for DBs which allow DISTINCT on all column types. $$statementref = "SELECT" . $QueryHint . "COUNT(DISTINCT main.id) FROM $$statementref"; } sub Fields { my $self = shift; my $table = lc shift; unless ( $FIELDS_IN_TABLE{$table} ) { $FIELDS_IN_TABLE{ $table } = []; my $sth = $self->dbh->column_info( undef, '', $table, '%' ) or return (); my $info = $sth->fetchall_arrayref({}); foreach my $e ( @$info ) { push @{ $FIELDS_IN_TABLE{ $table } }, $e->{'COLUMN_NAME'}; } } return @{ $FIELDS_IN_TABLE{ $table } }; } =head2 Log MESSAGE Takes a single argument, a message to log. Currently prints that message to STDERR =cut sub Log { my $self = shift; my $msg = shift; warn $msg."\n"; } =head2 SimpleDateTimeFunctions See L for details on supported functions. This method is for implementers of custom DB connectors. Returns hash reference with (function name, sql template) pairs. =cut sub SimpleDateTimeFunctions { my $self = shift; return { datetime => 'SUBSTR(?, 1, 19)', time => 'SUBSTR(?, 12, 8)', hourly => 'SUBSTR(?, 1, 13)', hour => 'SUBSTR(?, 12, 2 )', date => 'SUBSTR(?, 1, 10)', daily => 'SUBSTR(?, 1, 10)', day => 'SUBSTR(?, 9, 2 )', dayofmonth => 'SUBSTR(?, 9, 2 )', monthly => 'SUBSTR(?, 1, 7 )', month => 'SUBSTR(?, 6, 2 )', annually => 'SUBSTR(?, 1, 4 )', year => 'SUBSTR(?, 1, 4 )', }; } =head2 DateTimeFunction Takes named arguments: =over 4 =item * Field - SQL expression date/time function should be applied to. Note that this argument is used as is without any kind of quoting. =item * Type - name of the function, see supported values below. =item * Timezone - optional hash reference with From and To values, see L for details. =back Returns SQL statement. Returns NULL if function is not supported. =head3 Supported functions Type value in L is case insesitive. Spaces, underscores and dashes are ignored. So 'date time', 'DateTime' and 'date_time' are all synonyms. The following functions are supported: =over 4 =item * date time - as is, no conversion, except applying timezone conversion if it's provided. =item * time - time only =item * hourly - datetime prefix up to the hours, e.g. '2010-03-25 16' =item * hour - hour, 0 - 23 =item * date - date only =item * daily - synonym for date =item * day of week - 0 - 6, 0 - Sunday =item * day - day of month, 1 - 31 =item * day of month - synonym for day =item * day of year - 1 - 366, support is database dependent =item * month - 1 - 12 =item * monthly - year and month prefix, e.g. '2010-11' =item * year - e.g. '2023' =item * annually - synonym for year =item * week of year - 0-53, presence of zero week, 1st week meaning and whether week starts on Monday or Sunday heavily depends on database. =back =cut sub DateTimeFunction { my $self = shift; my %args = ( Field => undef, Type => '', Timezone => undef, @_ ); my $res = $args{'Field'} || '?'; if ( $args{'Timezone'} ) { $res = $self->ConvertTimezoneFunction( %{ $args{'Timezone'} }, Field => $res, ); } my $norm_type = lc $args{'Type'}; $norm_type =~ s/[ _-]//g; if ( my $template = $self->SimpleDateTimeFunctions->{ $norm_type } ) { $template =~ s/\?/$res/; $res = $template; } else { return 'NULL'; } return $res; } =head2 ConvertTimezoneFunction Generates a function applied to Field argument that converts timezone. By default converts from UTC. Examples: # UTC => Moscow $handle->ConvertTimezoneFunction( Field => '?', To => 'Europe/Moscow'); If there is problem with arguments or timezones are equal then Field returned without any function applied. Field argument is not escaped in any way, it's your job. Implementation is very database specific. To be portable convert from UTC or to UTC. Some databases have internal storage for information about timezones that should be kept up to date. Read documentation for your DB. =cut sub ConvertTimezoneFunction { my $self = shift; my %args = ( From => 'UTC', To => undef, Field => '', @_ ); return $args{'Field'}; } =head2 DateTimeIntervalFunction Generates a function to calculate interval in seconds between two dates. Takes From and To arguments which can be either scalar or a hash. Hash is processed with L. Arguments are not quoted or escaped in any way. It's caller's job. =cut sub DateTimeIntervalFunction { my $self = shift; my %args = ( From => undef, To => undef, @_ ); $_ = DBIx::SearchBuilder->CombineFunctionWithField(%$_) for grep ref, @args{'From', 'To'}; return $self->_DateTimeIntervalFunction( %args ); } sub _DateTimeIntervalFunction { return 'NULL' } =head2 NullsOrder Sets order of NULLs when sorting columns when called with mode, but only if DB supports it. Modes: =over 4 =item * small NULLs are smaller then anything else, so come first when order is ASC and last otherwise. =item * large NULLs are larger then anything else. =item * first NULLs are always first. =item * last NULLs are always last. =item * default Return back to DB's default behaviour. =back When called without argument returns metadata required to generate SQL. =cut sub NullsOrder { my $self = shift; unless ($self->HasSupportForNullsOrder) { warn "No support for changing NULLs order" if @_; return undef; } if ( @_ ) { my $mode = shift || 'default'; if ( $mode eq 'default' ) { delete $self->{'nulls_order'}; } elsif ( $mode eq 'small' ) { $self->{'nulls_order'} = { ASC => 'NULLS FIRST', DESC => 'NULLS LAST' }; } elsif ( $mode eq 'large' ) { $self->{'nulls_order'} = { ASC => 'NULLS LAST', DESC => 'NULLS FIRST' }; } elsif ( $mode eq 'first' ) { $self->{'nulls_order'} = { ASC => 'NULLS FIRST', DESC => 'NULLS FIRST' }; } elsif ( $mode eq 'last' ) { $self->{'nulls_order'} = { ASC => 'NULLS LAST', DESC => 'NULLS LAST' }; } else { warn "'$mode' is not supported NULLs ordering mode"; delete $self->{'nulls_order'}; } } return undef unless $self->{'nulls_order'}; return $self->{'nulls_order'}; } =head2 HasSupportForNullsOrder Returns true value if DB supports adjusting NULLs order while sorting a column, for example C. =cut sub HasSupportForNullsOrder { return 0; } =head2 HasSupportForCombineSearchAndCount Returns true value if DB supports to combine search and count in single query. =cut sub HasSupportForCombineSearchAndCount { return 1; } =head2 QuoteName Quote table or column name to avoid reserved word errors. Returns same value passed unless over-ridden in database-specific subclass. =cut # over-ride in subclass sub QuoteName { my ($self, $name) = @_; # use dbi built in quoting if we have a connection, if ($self->dbh) { return $self->dbh->quote_identifier($name); } warn "QuoteName called without a db handle"; return $name; } =head2 DequoteName Undo the effects of QuoteName by removing quoting. =cut sub DequoteName { my ($self, $name) = @_; if ($self->dbh) { # 29 = SQL_IDENTIFIER_QUOTE_CHAR; see "perldoc DBI" my $quote_char = $self->dbh->get_info( 29 ); if ($quote_char) { if ($name =~ /^$quote_char(.*)$quote_char$/) { return $1; } } return $name; } warn "DequoteName called without a db handle"; return $name; } sub _ExtractBindValues { my $self = shift; my $string = shift; my $default_escape_char = shift || q{'}; return $string unless defined $string; my $placeholder = ''; my @chars = split //, $string; my $value = ''; my $escape_char = $default_escape_char; my @values; my $in = 0; # keep state in the loop: is it in a quote? while ( defined( my $c = shift @chars ) ) { my $escaped; if ( $c eq $escape_char && $in ) { if ( $escape_char eq q{'} ) { if ( ( $chars[0] || '' ) eq q{'} ) { $c = shift @chars; $escaped = 1; } } else { $c = shift @chars; $escaped = 1; } } if ($in) { if ( $c eq q{'} ) { if ( !$escaped ) { push @values, $value; $in = 0; $value = ''; $escape_char = $default_escape_char; $placeholder .= '?'; next; } } $value .= $c; } else { if ( $c eq q{'} ) { $in = 1; } # Handle quoted string like e'foo\\bar' elsif ( lc $c eq 'e' && ( $chars[0] // '' ) eq q{'} ) { $escape_char = '\\'; } # Handle numbers elsif ( $c =~ /[\d.]/ && $placeholder !~ /\w$/ ) { # Do not catch Groups_1.Name $value .= $c; while ( ( $chars[0] // '' ) =~ /[\d.]/ ) { $value .= shift @chars; } push @values, $value; $placeholder .= '?'; $value = ''; } else { $placeholder .= $c; } } } return ( $placeholder, @values ); } sub _RequireQuotedTables { 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}; } =head2 CastAsDecimal FIELD Cast the given field as decimal. E.g. on Pg, it's C. =cut sub CastAsDecimal { my $self = shift; my $field = shift or return; return "CAST($field AS DECIMAL)"; } 1; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/SchemaGenerator.pm0000644000076500000240000001061714431214576024022 0ustar sunnavystaffuse strict; use warnings; package DBIx::SearchBuilder::SchemaGenerator; use base qw(Class::Accessor); use DBIx::DBSchema; use Class::ReturnValue; # Public accessors __PACKAGE__->mk_accessors(qw(handle)); # Internal accessors: do not use from outside class __PACKAGE__->mk_accessors(qw(_db_schema)); =head2 new HANDLE Creates a new C object. The single required argument is a C. =cut sub new { my $class = shift; my $handle = shift; my $self = $class->SUPER::new(); $self->handle($handle); my $schema = DBIx::DBSchema->new; $self->_db_schema($schema); return $self; } =for public_doc AddModel MODEL Adds a new model class to the SchemaGenerator. Model should either be an object of a subclass of C, or the name of such a subclass; in the latter case, C will instantiate an object of the subclass. The model must define the instance methods C and C. Returns true if the model was added successfully; returns a false C error otherwise. =cut sub AddModel { my $self = shift; my $model = shift; # $model could either be a (presumably unfilled) object of a subclass of # DBIx::SearchBuilder::Record, or it could be the name of such a subclass. unless (ref $model and UNIVERSAL::isa($model, 'DBIx::SearchBuilder::Record')) { my $new_model; eval { $new_model = $model->new; }; if ($@) { return $self->_error("Error making new object from $model: $@"); } return $self->_error("Didn't get a DBIx::SearchBuilder::Record from $model, got $new_model") unless UNIVERSAL::isa($new_model, 'DBIx::SearchBuilder::Record'); $model = $new_model; } my $table_obj = $self->_DBSchemaTableFromModel($model); $self->_db_schema->addtable($table_obj); 1; } =for public_doc CreateTableSQLStatements Returns a list of SQL statements (as strings) to create tables for all of the models added to the SchemaGenerator. =cut sub CreateTableSQLStatements { my $self = shift; # The sort here is to make it predictable, so that we can write tests. return sort $self->_db_schema->sql($self->handle->dbh); } =for public_doc CreateTableSQLText Returns a string containing a sequence of SQL statements to create tables for all of the models added to the SchemaGenerator. =cut sub CreateTableSQLText { my $self = shift; return join "\n", map { "$_ ;\n" } $self->CreateTableSQLStatements; } =for private_doc _DBSchemaTableFromModel MODEL Takes an object of a subclass of DBIx::SearchBuilder::Record; returns a new C object corresponding to the model. =cut sub _DBSchemaTableFromModel { my $self = shift; my $model = shift; my $table_name = $model->Table; my $schema = $model->Schema; my $primary = "id"; # TODO allow override my $primary_col = DBIx::DBSchema::Column->new({ name => $primary, type => 'serial', null => 'NOT NULL', }); my @cols = ($primary_col); # The sort here is to make it predictable, so that we can write tests. for my $field (sort keys %$schema) { # Skip foreign keys next if defined $schema->{$field}->{'REFERENCES'} and defined $schema->{$field}->{'KEY'}; # TODO XXX FIXME # In lieu of real reference support, make references just integers $schema->{$field}{'TYPE'} = 'integer' if $schema->{$field}{'REFERENCES'}; push @cols, DBIx::DBSchema::Column->new({ name => $field, type => $schema->{$field}{'TYPE'}, null => 'NULL', default => $schema->{$field}{'DEFAULT'}, }); } my $table = DBIx::DBSchema::Table->new({ name => $table_name, primary_key => $primary, columns => \@cols, }); return $table; } =for private_doc _error STRING Takes in a string and returns it as a Class::ReturnValue error object. =cut sub _error { my $self = shift; my $message = shift; my $ret = Class::ReturnValue->new; $ret->as_error(errno => 1, message => $message); return $ret->return_value; } 1; # Magic true value required at end of module __END__ =head1 NAME DBIx::SearchBuilder::SchemaGenerator - Generate table schemas from DBIx::SearchBuilder records =head1 SYNOPSIS use DBIx::SearchBuilder::SchemaGenerator; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Record.pm0000755000076500000240000010613414552307427022176 0ustar sunnavystaffpackage DBIx::SearchBuilder::Record; use strict; use warnings; use vars qw($AUTOLOAD); use Class::ReturnValue; use Encode qw(); use DBIx::SearchBuilder::Util qw/ sorted_values /; =head1 NAME DBIx::SearchBuilder::Record - Superclass for records loaded by SearchBuilder =head1 SYNOPSIS package MyRecord; use base qw/DBIx::SearchBuilder::Record/; sub _Init { my $self = shift; my $DBIxHandle = shift; # A DBIx::SearchBuilder::Handle::foo object for your database $self->_Handle($DBIxHandle); $self->Table("Users"); } # Tell Record what the primary keys are sub _PrimaryKeys { return ['id']; } # Preferred and most efficient way to specify fields attributes in a derived # class, used by the autoloader to construct Attrib and SetAttrib methods. # read: calling $Object->Foo will return the value of this record's Foo column # write: calling $Object->SetFoo with a single value will set Foo's value in # both the loaded object and the database sub _ClassAccessible { { Tofu => { 'read' => 1, 'write' => 1 }, Maz => { 'auto' => 1, }, Roo => { 'read' => 1, 'auto' => 1, 'public' => 1, }, }; } # A subroutine to check a user's password without returning the current value # For security purposes, we didn't expose the Password method above sub IsPassword { my $self = shift; my $try = shift; # note two __s in __Value. Subclasses may muck with _Value, but # they should never touch __Value if ( $try eq $self->__Value('Password') ) { return (1); } else { return (undef); } } # Override DBIx::SearchBuilder::Create to do some checking on create sub Create { my $self = shift; my %fields = ( UserId => undef, Password => 'default', #Set a default password @_ ); # Make sure a userid is specified unless ( $fields{'UserId'} ) { die "No userid specified."; } # Get DBIx::SearchBuilder::Record->Create to do the real work return ( $self->SUPER::Create( UserId => $fields{'UserId'}, Password => $fields{'Password'}, Created => time ) ); } =head1 DESCRIPTION DBIx::SearchBuilder::Record is designed to work with DBIx::SearchBuilder. =head2 What is it trying to do. DBIx::SearchBuilder::Record abstracts the agony of writing the common and generally simple SQL statements needed to serialize and De-serialize an object to the database. In a traditional system, you would define various methods on your object 'create', 'find', 'modify', and 'delete' being the most common. In each method you would have a SQL statement like: select * from table where value='blah'; If you wanted to control what data a user could modify, you would have to do some special magic to make accessors do the right thing. Etc. The problem with this approach is that in a majority of the cases, the SQL is incredibly simple and the code from one method/object to the next was basically the same. Enter, DBIx::SearchBuilder::Record. With Record, you can in the simple case, remove all of that code and replace it by defining two methods and inheriting some code. It's pretty simple, and incredibly powerful. For more complex cases, you can do more complicated things by overriding certain methods. Let's stick with the simple case for now. The two methods in question are L and L. All they really do are define some values and send you on your way. As you might have guessed the '_' means that these are private methods. They will get called by your record object's constructor. =over 4 =item '_Init' Defines what table we are talking about, and set a variable to store the database handle. =item '_ClassAccessible Defines what operations may be performed on various data selected from the database. For example you can define fields to be mutable, or immutable, there are a few other options but I don't understand what they do at this time. =back And really, that's it. So let's have some sample code. =head2 An Annotated Example The example code below makes the following assumptions: =over 4 =item * The database is 'postgres', =item * The host is 'reason', =item * The login name is 'mhat', =item * The database is called 'example', =item * The table is called 'simple', =item * The table looks like so: id integer not NULL, primary_key(id), foo varchar(10), bar varchar(10) =back First, let's define our record class in a new module named "Simple.pm". 000: package Simple; 001: use DBIx::SearchBuilder::Record; 002: @ISA = (DBIx::SearchBuilder::Record); This should be pretty obvious, name the package, import ::Record and then define ourself as a subclass of ::Record. 003: 004: sub _Init { 005: my $this = shift; 006: my $handle = shift; 007: 008: $this->_Handle($handle); 009: $this->Table("Simple"); 010: 011: return ($this); 012: } Here we set our handle and table name. While it's not obvious so far, we'll see later that $handle (line: 006) gets passed via C<::Record::new> when a new instance is created. That's actually an important concept: the DB handle is not bound to a single object but rather, it is shared across objects. 013: 014: sub _ClassAccessible { 015: { 016: Foo => { 'read' => 1 }, 017: Bar => { 'read' => 1, 'write' => 1 }, 018: Id => { 'read' => 1 } 019: }; 020: } What's happening might be obvious, but just in case this method is going to return a reference to a hash. That hash is where our columns are defined, as well as what type of operations are acceptable. 021: 022: 1; Like all perl modules, this needs to end with a true value. Now, on to the code that will actually *do* something with this object. This code would be placed in your Perl script. 000: use DBIx::SearchBuilder::Handle; 001: use Simple; Use two packages, the first is where I get the DB handle from, the latter is the object I just created. 002: 003: my $handle = DBIx::SearchBuilder::Handle->new(); 004: $handle->Connect( 'Driver' => 'Pg', 005: 'Database' => 'test', 006: 'Host' => 'reason', 007: 'User' => 'mhat', 008: 'Password' => ''); Creates a new DBIx::SearchBuilder::Handle, and then connects to the database using that handle. Pretty straight forward, the password '' is what I use when there is no password. I could probably leave it blank, but I find it to be more clear to define it. 009: 010: my $s = Simple->new($handle); 011: 012: $s->LoadById(1); LoadById is one of four 'LoadBy' methods, as the name suggests it searches for an row in the database that has id='0'. ::SearchBuilder has, what I think is a bug, in that it current requires there to be an id field. More reasonably it also assumes that the id field is unique. LoadById($id) will do undefined things if there is >1 row with the same id. In addition to LoadById, we also have: =over 4 =item LoadByCol Takes two arguments, a column name and a value. Again, it will do undefined things if you use non-unique things. =item LoadByCols Takes a hash of columns=>values and returns the *first* to match. First is probably lossy across databases vendors. =item LoadFromHash Populates this record with data from a DBIx::SearchBuilder. I'm currently assuming that DBIx::SearchBuilder is what we use in cases where we expect > 1 record. More on this later. =back Now that we have a populated object, we should do something with it! ::Record automagically generates accessos and mutators for us, so all we need to do is call the methods. Accessors are named (), and Mutators are named Set($). On to the example, just appending this to the code from the last example. 013: 014: print "ID : ", $s->Id(), "\n"; 015: print "Foo : ", $s->Foo(), "\n"; 016: print "Bar : ", $s->Bar(), "\n"; That's all you have to to get the data. Now to change the data! 017: 018: $s->SetBar('NewBar'); Pretty simple! That's really all there is to it. Set($) returns a boolean and a string describing the problem. Let's look at an example of what will happen if we try to set a 'Id' which we previously defined as read only. 019: my ($res, $str) = $s->SetId('2'); 020: if (! $res) { 021: ## Print the error! 022: print "$str\n"; 023: } The output will be: >> Immutable field Currently Set updates the data in the database as soon as you call it. In the future I hope to extend ::Record to better support transactional operations, such that updates will only happen when "you" say so. Finally, adding a removing records from the database. ::Record provides a Create method which simply takes a hash of key=>value pairs. The keys exactly map to database fields. 023: ## Get a new record object. 024: $s1 = Simple->new($handle); 025: $s1->Create('Id' => 4, 026: 'Foo' => 'Foooooo', 027: 'Bar' => 'Barrrrr'); Poof! A new row in the database has been created! Now let's delete the object! 028: 029: $s1 = undef; 030: $s1 = Simple->new($handle); 031: $s1->LoadById(4); 032: $s1->Delete(); And it's gone. For simple use, that's more or less all there is to it. In the future, we hope to expand this how-to to discuss using container classes, overloading, etc. =head1 METHOD NAMING Each method has a lower case alias; '_' is used to separate words. For example, the method C<_PrimaryKeys> has the alias C<_primary_keys>. =head1 METHODS =cut =head2 new Instantiate a new record object. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless ($self, $class); $self->_Init(@_); return $self; } # Not yet documented here. Should almost certainly be overloaded. sub _Init { my $self = shift; my $handle = shift; $self->_Handle($handle); } =head2 id Returns this row's primary key. =cut *id = \&Id; sub Id { my $pkey = $_[0]->_PrimaryKey(); return $_[0]->{'values'}->{ $pkey }; } =head2 primary_keys =head2 PrimaryKeys Return a hash of the values of our primary keys for this function. =cut sub PrimaryKeys { my $self = shift; return map { $_ => $self->{'values'}->{lc $_} } @{$self->_PrimaryKeys}; } sub DESTROY { return 1; } sub AUTOLOAD { my $self = $_[0]; no strict 'refs'; my ($Attrib) = ( $AUTOLOAD =~ /::(\w+)$/o ); if ( $self->_Accessible( $Attrib, 'read' ) ) { *{$AUTOLOAD} = sub { return ( $_[0]->_Value($Attrib) ) }; goto &$AUTOLOAD; } elsif ( $self->_Accessible( $Attrib, 'record-read') ) { *{$AUTOLOAD} = sub { $_[0]->_ToRecord( $Attrib, $_[0]->__Value($Attrib) ) }; goto &$AUTOLOAD; } elsif ( $self->_Accessible( $Attrib, 'foreign-collection') ) { *{$AUTOLOAD} = sub { $_[0]->_CollectionValue( $Attrib ) }; goto &$AUTOLOAD; } elsif ( $AUTOLOAD =~ /.*::[sS]et_?(\w+)/o ) { $Attrib = $1; if ( $self->_Accessible( $Attrib, 'write' ) ) { *{$AUTOLOAD} = sub { return ( $_[0]->_Set( Field => $Attrib, Value => $_[1] ) ); }; goto &$AUTOLOAD; } elsif ( $self->_Accessible( $Attrib, 'record-write') ) { *{$AUTOLOAD} = sub { my $self = shift; my $val = shift; $val = $val->id if UNIVERSAL::isa($val, 'DBIx::SearchBuilder::Record'); return ( $self->_Set( Field => $Attrib, Value => $val ) ); }; goto &$AUTOLOAD; } elsif ( $self->_Accessible( $Attrib, 'read' ) ) { *{$AUTOLOAD} = sub { return ( 0, 'Immutable field' ) }; goto &$AUTOLOAD; } else { return ( 0, 'Nonexistant field?' ); } } elsif ( $AUTOLOAD =~ /.*::(\w+?)_?[oO]bj$/o ) { $Attrib = $1; if ( $self->_Accessible( $Attrib, 'object' ) ) { *{$AUTOLOAD} = sub { return (shift)->_Object( Field => $Attrib, Args => [@_], ); }; goto &$AUTOLOAD; } else { return ( 0, 'No object mapping for field' ); } } #Previously, I checked for writability here. but I'm not sure that's the #right idea. it breaks the ability to do ValidateQueue for a ticket #on creation. elsif ( $AUTOLOAD =~ /.*::[vV]alidate_?(\w+)/o ) { $Attrib = $1; *{$AUTOLOAD} = sub { return ( $_[0]->_Validate( $Attrib, $_[1] ) ) }; goto &$AUTOLOAD; } # TODO: if autoload = 0 or 1 _ then a combination of lowercase and _ chars, # turn them into studlycapped phrases else { my ( $package, $filename, $line ); ( $package, $filename, $line ) = caller; die "$AUTOLOAD Unimplemented in $package. ($filename line $line) \n"; } } =head2 _Accessible KEY MODE Private method. Returns undef unless C is accessible in C otherwise returns C value =cut sub _Accessible { my $self = shift; my $attr = shift; my $mode = lc(shift || ''); my $attribute = $self->_ClassAccessible(@_)->{$attr}; return unless defined $attribute; return $attribute->{$mode}; } =head2 _PrimaryKeys Return our primary keys. (Subclasses should override this, but our default is that we have one primary key, named 'id'.) =cut sub _PrimaryKeys { my $self = shift; return ['id']; } sub _PrimaryKey { my $self = shift; my $pkeys = $self->_PrimaryKeys(); die "No primary key" unless ( ref($pkeys) eq 'ARRAY' and $pkeys->[0] ); die "Too many primary keys" unless ( scalar(@$pkeys) == 1 ); return $pkeys->[0]; } =head2 _ClassAccessible An older way to specify fields attributes in a derived class. (The current preferred method is by overriding C; if you do this and don't override C<_ClassAccessible>, the module will generate an appropriate C<_ClassAccessible> based on your C.) Here's an example declaration: sub _ClassAccessible { { Tofu => { 'read'=>1, 'write'=>1 }, Maz => { 'auto'=>1, }, Roo => { 'read'=>1, 'auto'=>1, 'public'=>1, }, }; } =cut sub _ClassAccessible { my $self = shift; return $self->_ClassAccessibleFromSchema if $self->can('Schema'); # XXX This is stub code to deal with the old way we used to do _Accessible # It should never be called by modern code my %accessible; while ( my $col = shift ) { $accessible{$col}->{lc($_)} = 1 foreach split(/[\/,]/, shift); } return(\%accessible); } sub _ClassAccessibleFromSchema { my $self = shift; my $accessible = {}; foreach my $key ($self->_PrimaryKeys) { $accessible->{$key} = { 'read' => 1 }; }; my $schema = $self->Schema; for my $field (keys %$schema) { if ($schema->{$field}{'TYPE'}) { $accessible->{$field} = { 'read' => 1, 'write' => 1 }; } elsif (my $refclass = $schema->{$field}{'REFERENCES'}) { if (UNIVERSAL::isa($refclass, 'DBIx::SearchBuilder::Record')) { if ($field =~ /(.*)_id$/) { $accessible->{$field} = { 'read' => 1, 'write' => 1 }; $accessible->{$1} = { 'record-read' => 1, 'column' => $field }; } else { $accessible->{$field} = { 'record-read' => 1, 'record-write' => 1 }; } } elsif (UNIVERSAL::isa($refclass, 'DBIx::SearchBuilder')) { $accessible->{$field} = { 'foreign-collection' => 1 }; } else { warn "Error: $refclass neither Record nor Collection"; } } } return $accessible; } sub _ToRecord { my $self = shift; my $field = shift; my $value = shift; return unless defined $value; my $schema = $self->Schema; my $description = $schema->{$field} || $schema->{$field . "_id"}; die "Can't get schema for $field on $self" unless $description; return unless $description; return $value unless $description->{'REFERENCES'}; my $classname = $description->{'REFERENCES'}; return unless UNIVERSAL::isa($classname, 'DBIx::SearchBuilder::Record'); # XXX TODO FIXME perhaps this is not what should be passed to new, but it needs it my $object = $classname->new( $self->_Handle ); $object->LoadById( $value ); return $object; } sub _CollectionValue { my $self = shift; my $method_name = shift; return unless defined $method_name; my $schema = $self->Schema; my $description = $schema->{$method_name}; return unless $description; my $classname = $description->{'REFERENCES'}; return unless UNIVERSAL::isa($classname, 'DBIx::SearchBuilder'); my $coll = $classname->new( Handle => $self->_Handle ); $coll->Limit( FIELD => $description->{'KEY'}, VALUE => $self->id); return $coll; } # sub {{{ ReadableAttributes =head2 ReadableAttributes Returns an array of the attributes of this class defined as "read" => 1 in this class' _ClassAccessible datastructure =cut sub ReadableAttributes { my $self = shift; my $ca = $self->_ClassAccessible(); my @readable = grep { $ca->{$_}->{'read'} or $ca->{$_}->{'record-read'} } sort keys %{$ca}; return (@readable); } =head2 WritableAttributes Returns an array of the attributes of this class defined as "write" => 1 in this class' _ClassAccessible datastructure =cut sub WritableAttributes { my $self = shift; my $ca = $self->_ClassAccessible(); my @writable = grep { $ca->{$_}->{'write'} || $ca->{$_}->{'record-write'} } sort keys %{$ca}; return @writable; } =head2 __Value Takes a field name and returns that field's value. Subclasses should never override __Value. =cut sub __Value { my $self = shift; my $field = lc shift; $field = $self->_Accessible($field, "column") || $field; return $self->{'values'}{$field} if $self->{'fetched'}{$field}; $self->{'fetched'}{$field} = 1; my %pk = $self->PrimaryKeys; return undef if grep !defined, values %pk; my $query = "SELECT $field FROM ". $self->QuotedTableName ." WHERE ". join " AND ", map "$_ = ?", sort keys %pk; my $sth = $self->_Handle->SimpleQuery( $query, sorted_values(%pk) ) or return undef; return $self->{'values'}{$field} = ($sth->fetchrow_array)[0]; } =head2 _Value _Value takes a single column name and returns that column's value for this row. Subclasses can override _Value to insert custom access control. =cut sub _Value { my $self = shift; return ($self->__Value(@_)); } =head2 _Set _Set takes a single column name and a single unquoted value. It updates both the in-memory value of this column and the in-database copy. Subclasses can override _Set to insert custom access control. =cut sub _Set { my $self = shift; return ($self->__Set(@_)); } sub __Set { my $self = shift; my %args = ( 'Field' => undef, 'Value' => undef, 'IsSQL' => undef, @_ ); $args{'Column'} = delete $args{'Field'}; $args{'IsSQLFunction'} = delete $args{'IsSQL'}; my $ret = Class::ReturnValue->new(); unless ( $args{'Column'} ) { $ret->as_array( 0, 'No column specified' ); $ret->as_error( errno => 5, do_backtrace => 0, message => "No column specified" ); return ( $ret->return_value ); } my $column = lc $args{'Column'}; # XXX: OLD behaviour, no_undefs_in_set will go away if ( !defined $args{'Value'} && $self->{'no_undefs_in_set' } ) { $ret->as_array( 0, "No value passed to _Set" ); $ret->as_error( errno => 2, do_backtrace => 0, message => "No value passed to _Set" ); return ( $ret->return_value ); } if ( defined $args{'Value'} ) { if ( $args{'Value'} eq '' && ( $self->_Accessible( $args{'Column'}, 'is_numeric' ) || ($self->_Accessible( $args{'Column'}, 'type' ) || '') =~ /INT/i ) ) { $args{'Value'} = 0; } } else { if ( $self->_Accessible( $args{Column}, 'no_nulls' ) ) { my $default = $self->_Accessible( $args{Column}, 'default' ); if ( defined $default ) { $args{'Value'} = $default; } else { $ret->as_array( 0, 'Illegal value for non-nullable field ' . $args{'Column'} . ": undef/null value provided and no default specified by class" ); $ret->as_error( errno => 3, do_backtrace => 0, message => "Illegal value for non-nullable field " . $args{'Column'} . ": undef/null value provided and no default specified by class" ); return ( $ret->return_value ); } } } # First, we truncate the value, if we need to. $args{'Value'} = $self->TruncateValue( $args{'Column'}, $args{'Value'} ); my $current_value = $self->__Value($column); if ( ( !defined $args{'Value'} && !defined $current_value ) || ( defined $args{'Value'} && defined $current_value && ( $args{'Value'} eq $current_value ) ) ) { $ret->as_array( 0, "That is already the current value" ); $ret->as_error( errno => 1, do_backtrace => 0, message => "That is already the current value" ); return ( $ret->return_value ); } my $method = "Validate" . $args{'Column'}; unless ( $self->$method( $args{'Value'} ) ) { $ret->as_array( 0, 'Illegal value for ' . $args{'Column'} ); $ret->as_error( errno => 3, do_backtrace => 0, message => "Illegal value for " . $args{'Column'} ); return ( $ret->return_value ); } $args{'Table'} = $self->Table(); $args{'PrimaryKeys'} = { $self->PrimaryKeys() }; # The blob handling will destroy $args{'Value'}. But we assign # that back to the object at the end. this works around that my $unmunged_value = $args{'Value'}; unless ( $self->_Handle->KnowsBLOBs ) { # Support for databases which don't deal with LOBs automatically my $ca = $self->_ClassAccessible(); my $key = $args{'Column'}; if ( ( $ca->{$key}->{'type'} // '' ) =~ /^(text|longtext|clob|longblob|blob|lob)$/i ) { my $bhash = $self->_Handle->BLOBParams( $key, $ca->{$key}->{'type'} ); $bhash->{'value'} = $args{'Value'}; $args{'Value'} = $bhash; } } my $val = $self->_Handle->UpdateRecordValue(%args); unless ($val) { my $message = $args{'Column'} . " could not be set to " . ( defined $args{'Value'} ? $args{'Value'} : 'undef' ) . "."; $ret->as_array( 0, $message); $ret->as_error( errno => 4, do_backtrace => 0, message => $message ); return ( $ret->return_value ); } # If we've performed some sort of "functional update" # then we need to reload the object from the DB to know what's # really going on. (ex SET Cost = Cost+5) if ( $args{'IsSQLFunction'} ) { $self->Load( $self->Id ); } else { $self->{'values'}->{"$column"} = $unmunged_value; } $ret->as_array( 1, "The new value has been set." ); return ( $ret->return_value ); } =head2 _Canonicalize PARAMHASH This routine massages an input value (VALUE) for FIELD into something that's going to be acceptable. Takes =over =item FIELD =item VALUE =item FUNCTION =back Takes: =over =item FIELD =item VALUE =item FUNCTION =back Returns a replacement VALUE. =cut sub _Canonicalize { my $self = shift; my $field = shift; } =head2 _Validate FIELD VALUE Validate that VALUE will be an acceptable value for FIELD. Currently, this routine does nothing whatsoever. If it succeeds (which is always the case right now), returns true. Otherwise returns false. =cut sub _Validate { my $self = shift; my $field = shift; my $value = shift; #Check type of input #If it's null, are nulls permitted? #If it's an int, check the # of bits #If it's a string, #check length #check for nonprintables #If it's a blob, check for length #In an ideal world, if this is a link to another table, check the dependency. return(1); } =head2 TruncateValue KEY VALUE Truncate a value that's about to be set so that it will fit inside the database' s idea of how big the column is. (Actually, it looks at SearchBuilder's concept of the database, not directly into the db). =cut sub TruncateValue { my $self = shift; my $key = shift; my $value = shift; # We don't need to truncate empty things. return undef unless defined $value; my $metadata = $self->_ClassAccessible->{$key}; return $value unless $metadata; my $truncate_to; if ( $metadata->{'length'} && !$metadata->{'is_numeric'} ) { $truncate_to = int $metadata->{'length'}; } elsif ($metadata->{'type'} && $metadata->{'type'} =~ /char\((\d+)\)/ ) { $truncate_to = $1; } return $value unless $truncate_to; # return asap if length in bytes is smaller than limit return $value if $truncate_to >= do { use bytes; length $value }; if ( Encode::is_utf8($value) ) { return Encode::decode_utf8( substr( Encode::encode_utf8( $value ), 0, $truncate_to ), Encode::FB_QUIET(), ); } else { # XXX: if it's not UTF-8 then why do we convert it to? return Encode::encode_utf8( Encode::decode_utf8 ( substr( $value, 0, $truncate_to ), Encode::FB_QUIET(), ) ); } } =head2 _Object _Object takes a single column name and an array reference. It creates new object instance of class specified in _ClassAccessable structure and calls LoadById on recently created object with the current column value as argument. It uses the array reference as the object constructor's arguments. Subclasses can override _Object to insert custom access control or define default constructor arguments. Note that if you are using a C with a C field, this is unnecessary: the method to access the column's value will automatically turn it into the appropriate object. =cut sub _Object { my $self = shift; return $self->__Object(@_); } sub __Object { my $self = shift; my %args = ( Field => '', Args => [], @_ ); my $field = $args{'Field'}; my $class = $self->_Accessible( $field, 'object' ); # Globs magic to be sure that we call 'eval "require $class"' only once # because eval is quite slow -- cubic@acronis.ru no strict qw( refs ); my $vglob = ${ $class . '::' }{'VERSION'}; unless ( $vglob && *$vglob{'SCALAR'} ) { eval "require $class"; die "Couldn't use $class: $@" if ($@); unless ( $vglob && *$vglob{'SCALAR'} ) { *{ $class . "::VERSION" } = '-1, By DBIx::SearchBuilder'; } } my $object = $class->new( @{ $args{'Args'} } ); $object->LoadById( $self->__Value($field) ); return $object; } # load should do a bit of overloading # if we call it with only one argument, we're trying to load by reference. # if we call it with a passel of arguments, we're trying to load by value # The latter is primarily important when we've got a whole set of record that we're # reading in with a recordset class and want to instantiate objefcts for each record. =head2 Load Takes a single argument, $id. Calls LoadById to retrieve the row whose primary key is $id =cut sub Load { my $self = shift; return $self->LoadById(@_); } =head2 LoadByCol Takes two arguments, a column and a value. The column can be any table column which contains unique values. Behavior when using a non-unique value is undefined =cut sub LoadByCol { my $self = shift; return $self->LoadByCols(@_); } =head2 LoadByCols Takes a hash of columns and values. Loads the first record that matches all keys. The hash's keys are the columns to look at. The hash's values are either: scalar values to look for OR has references which contain 'operator' and 'value' =cut sub LoadByCols { my $self = shift; my %hash = (@_); my (@bind, @phrases); foreach my $key (sort keys %hash) { if (defined $hash{$key} && $hash{$key} ne '') { my $op; my $value; my $function = "?"; if (ref $hash{$key} eq 'HASH') { $op = $hash{$key}->{operator}; $value = $hash{$key}->{value}; $function = $hash{$key}->{function} || "?"; } else { $op = '='; $value = $hash{$key}; } push @phrases, "$key $op $function"; push @bind, $value; } else { push @phrases, "($key IS NULL OR $key = ?)"; my $meta = $self->_ClassAccessible->{$key}; $meta->{'type'} ||= ''; # TODO: type checking should be done in generic way if ( $meta->{'is_numeric'} || $meta->{'type'} =~ /INT|NUMERIC|DECIMAL|REAL|DOUBLE|FLOAT/i ) { push @bind, 0; } else { push @bind, ''; } } } my $QueryString = "SELECT * FROM ".$self->QuotedTableName." WHERE ". join(' AND ', @phrases) ; return ($self->_LoadFromSQL($QueryString, @bind)); } =head2 LoadById Loads a record by its primary key. Your record class must define a single primary key column. =cut sub LoadById { my ($self, $id) = @_; return $self->LoadByCols( $self->_PrimaryKey, defined $id? $id: 0 ); } =head2 LoadByPrimaryKeys Like LoadById with basic support for compound primary keys. =cut sub LoadByPrimaryKeys { my $self = shift; my $data = (ref $_[0] eq 'HASH')? $_[0]: {@_}; my %cols=(); foreach (@{$self->_PrimaryKeys}) { return (0, "Missing PK field: '$_'") unless defined $data->{$_}; $cols{$_}=$data->{$_}; } return ($self->LoadByCols(%cols)); } =head2 LoadFromHash Takes a hashref, such as created by DBIx::SearchBuilder and populates this record's loaded values hash. =cut sub LoadFromHash { my $self = shift; my $hashref = shift; foreach my $f ( keys %$hashref ) { $self->{'fetched'}{lc $f} = 1; } $self->{'values'} = $hashref; return $self->id(); } =head2 _LoadFromSQL QUERYSTRING @BIND_VALUES Load a record as the result of an SQL statement =cut sub _LoadFromSQL { my $self = shift; my $QueryString = shift; my @bind_values = (@_); my $sth = $self->_Handle->SimpleQuery( $QueryString, @bind_values ); #TODO this only gets the first row. we should check if there are more. return ( 0, "Couldn't execute query: ".$self->_Handle->dbh->errstr ) unless $sth; $self->{'values'} = $sth->fetchrow_hashref; $self->{'fetched'} = {}; if ( !$self->{'values'} && $sth->err ) { return ( 0, "Couldn't fetch row: ". $sth->err ); } unless ( $self->{'values'} ) { return ( 0, "Couldn't find row" ); } ## I guess to be consistant with the old code, make sure the primary ## keys exist. if( grep { not defined } $self->PrimaryKeys ) { return ( 0, "Missing a primary key?" ); } foreach my $f ( keys %{$self->{'values'}} ) { $self->{'fetched'}{lc $f} = 1; } return ( 1, "Found Object" ); } =head2 Create Takes an array of key-value pairs and drops any keys that aren't known as columns for this recordtype =cut sub Create { my $self = shift; my %attribs = @_; my ($key); foreach $key ( keys %attribs ) { if ( $self->_Accessible( $key, 'record-write' ) ) { $attribs{$key} = $attribs{$key}->id if UNIVERSAL::isa( $attribs{$key}, 'DBIx::SearchBuilder::Record' ); } if ( defined $attribs{$key} ) { if ( $attribs{$key} eq '' && ( $self->_Accessible( $key, 'is_numeric' ) || ($self->_Accessible( $key, 'type' ) || '') =~ /INT/i ) ) { $attribs{$key} = 0; } } else { $attribs{$key} = $self->_Accessible( $key, 'default' ) if $self->_Accessible( $key, 'no_nulls' ); } #Truncate things that are too long for their datatypes $attribs{$key} = $self->TruncateValue( $key => $attribs{$key} ); } unless ( $self->_Handle->KnowsBLOBs ) { # Support for databases which don't deal with LOBs automatically my $ca = $self->_ClassAccessible(); foreach $key ( keys %attribs ) { my $type = $ca->{$key}->{'type'}; next unless $type && $type =~ /^(text|longtext|clob|blob|lob|longblob)$/i; my $bhash = $self->_Handle->BLOBParams( $key, $type ); if ( ref($bhash) eq 'HASH' ) { $bhash->{'value'} = $attribs{$key}; $attribs{$key} = $bhash; } } } return ( $self->_Handle->Insert( $self->Table, %attribs ) ); } =head2 Delete Delete this record from the database. On failure return a Class::ReturnValue with the error. On success, return 1; =cut *delete = \&Delete; sub Delete { $_[0]->__Delete; } sub __Delete { my $self = shift; #TODO Check to make sure the key's not already listed. #TODO Update internal data structure ## Constructs the where clause. my @bind=(); my %pkeys=$self->PrimaryKeys(); my $where = 'WHERE '; foreach my $key (sort keys %pkeys) { $where .= $key . "=?" . " AND "; push (@bind, $pkeys{$key}); } $where =~ s/AND\s$//; my $QueryString = "DELETE FROM ". $self->QuotedTableName . ' ' . $where; my $return = $self->_Handle->SimpleQuery($QueryString, @bind); if (UNIVERSAL::isa($return, 'Class::ReturnValue')) { return ($return); } else { return(1); } } =head2 Table Returns or sets the name of the current Table =cut sub Table { my $self = shift; if (@_) { $self->{'table'} = shift; } return ($self->{'table'}); } =head2 QuotedTableName Returns the name of current Table, or the table provided as an argument, including any quoting based on yje Handle's QuoteTableNames flag and driver method. =cut sub QuotedTableName { my ($self, $name) = @_; unless ($name) { return $self->{'_quoted_table'} if defined $self->{'_quoted_table'}; $self->{'_quoted_table'} = $self->_Handle->QuoteTableNames ? $self->_Handle->QuoteName( $self->Table ) : $self->Table; return $self->{'_quoted_table'}; } return $self->_Handle->QuoteTableNames ? $self->_Handle->QuoteName($name) : $name; } =head2 _Handle Returns or sets the current DBIx::SearchBuilder::Handle object =cut sub _Handle { my $self = shift; if (@_) { $self->{'DBIxHandle'} = shift; } return ($self->{'DBIxHandle'}); } if( eval { require capitalization } ) { capitalization->unimport( __PACKAGE__ ); } 1; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder/Union.pm0000644000076500000240000001015314431214576022036 0ustar sunnavystaffpackage 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 reference 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; } 1; DBIx-SearchBuilder-1.81/lib/DBIx/SearchBuilder.pm0000755000076500000240000014727414552307741020771 0ustar sunnavystaff package DBIx::SearchBuilder; use strict; use warnings; our $VERSION = "1.81"; use Clone qw(); use Encode qw(); use Scalar::Util qw(blessed); use DBIx::SearchBuilder::Util qw/ sorted_values /; our $PREFER_BIND = $ENV{SB_PREFER_BIND}; =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 count_all subclauses restrictions _open_parens _close_parens group_by columns query_hint _bind_values _prefer_bind _combine_search_and_count ); #we have no limit statements. DoSearch won't work. $self->_isLimited(0); } =head2 Clone Returns copy of the current object with all search restrictions. =cut sub Clone { my $self = shift; my $obj = bless {}, ref($self); %$obj = %$self; delete $obj->{$_} for qw( items ); $obj->{'must_redo_search'} = 1; $obj->{'itemscount'} = 0; $obj->{ $_ } = Clone::clone( $obj->{ $_ } ) foreach grep exists $self->{ $_ }, $self->_ClonedAttributes; return $obj; } =head2 _ClonedAttributes Returns list of the object's fields that should be copied. If your subclass store references in the object that should be copied while clonning then you probably want override this method and add own values to the list. =cut sub _ClonedAttributes { return qw( aliases left_joins subclauses restrictions order_by group_by columns query_hint ); } =head2 _Handle [DBH] Get or set this object's DBIx::SearchBuilder::Handle object. =cut sub _Handle { my $self = shift; if (@_) { $self->{'DBIxHandle'} = shift; } return ( $self->{'DBIxHandle'} ); } =head2 _DoSearch This internal private method actually executes the search on the database; it is called automatically the first time that you actually need results (such as a call to C). =cut sub _DoSearch { my $self = shift; if ( $self->{_combine_search_and_count} ) { my ($count) = $self->_DoSearchAndCount; return $count; } my $QueryString = $self->BuildSelectQuery(); my $records = $self->_Handle->SimpleQuery( $QueryString, @{ $self->{_bind_values} || [] } ); return $self->__DoSearch($records); } sub __DoSearch { my $self = shift; my $records = shift; # 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; return 0 unless $records; while ( my $row = $records->fetchrow_hashref() ) { # search_builder_count_all is from combine search if ( !defined $self->{count_all} && $row->{search_builder_count_all} ) { $self->{count_all} = $row->{search_builder_count_all}; } 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; if ( $self->{_combine_search_and_count} ) { (undef, my $count_all) = $self->_DoSearchAndCount; return $count_all; } return $self->__DoCount; } sub __DoCount { my $self = shift; my $QueryString = $self->BuildSelectCountQuery(); my $records = $self->_Handle->SimpleQuery( $QueryString, @{ $self->{_bind_values} || [] } ); return 0 unless $records; my @row = $records->fetchrow_array(); return 0 if $records->err; $self->{'count_all'} = $row[0]; return ( $row[0] ); } =head2 _DoSearchAndCount This internal private method actually executes the search and also counting on the database; =cut sub _DoSearchAndCount { my $self = shift; my $QueryString = $self->BuildSelectAndCountQuery(); my $records = $self->_Handle->SimpleQuery( $QueryString, @{ $self->{_bind_values} || [] } ); undef $self->{count_all}; # __DoSearch updates count_all my $count = $self->__DoSearch($records); # If no results returned, we have to query the count separately. $self->{count_all} //= $self->__DoCount; return ( $count, $self->{count_all} ); } =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, $self); $$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 _DistinctQueryAndCount STATEMENTREF This routine takes a reference to a scalar containing an SQL statement. It massages the statement to ensure a distinct result set and total number of potential records are returned. =cut sub _DistinctQueryAndCount { my $self = shift; my $statementref = shift; $self->_Handle->DistinctQueryAndCount($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 PreferBind => 1|0 Builds a query string for a "SELECT rows from Tables" statement for this SearchBuilder object If C is true, the generated query will use bind variables where possible. If C is not passed, it defaults to package variable C<$DBIx::SearchBuilder::PREFER_BIND>, which defaults to C<$ENV{SB_PREFER_BIND}>. To override global C<$DBIx::SearchBuilder::PREFER_BIND> for current object only, you can also set C<_prefer_bind> accordingly, e.g. $sb->{_prefer_bind} = 1; =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 ); $self->_OptimizeQuery(\$QueryString, @_); my $QueryHint = $self->QueryHintFormatted; # DISTINCT query only required for multi-table selects # when we have group by clause then the result set is distinct as # it must contain only columns we group by or results of aggregate # functions which give one result per group, so we can skip DISTINCTing if ( my $clause = $self->_GroupClause ) { $QueryString = "SELECT" . $QueryHint . "main.* FROM $QueryString"; $QueryString .= $clause; $QueryString .= $self->_OrderClause; } elsif ( !$self->{'joins_are_distinct'} && $self->_isJoined ) { $self->_DistinctQuery(\$QueryString); } else { $QueryString = "SELECT" . $QueryHint . "main.* FROM $QueryString"; $QueryString .= $self->_OrderClause; } $self->_ApplyLimits(\$QueryString); return($QueryString) } =head2 BuildSelectCountQuery PreferBind => 1|0 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 ); $self->_OptimizeQuery(\$QueryString, @_); # DISTINCT query only required for multi-table selects if ($self->_isJoined) { $QueryString = $self->_Handle->DistinctCount(\$QueryString, $self); } else { my $QueryHint = $self->QueryHintFormatted; $QueryString = "SELECT" . $QueryHint . "count(main.id) FROM " . $QueryString; } return ($QueryString); } =head2 BuildSelectAndCountQuery PreferBind => 1|0 Builds a query string that is a combination of BuildSelectQuery and BuildSelectCountQuery. =cut sub BuildSelectAndCountQuery { my $self = shift; # Generally it's BuildSelectQuery plus extra COUNT part. my $QueryString = $self->_BuildJoins . " "; $QueryString .= $self->_WhereClause . " " if ( $self->_isLimited > 0 ); $self->_OptimizeQuery( \$QueryString, @_ ); my $QueryHint = $self->QueryHintFormatted; if ( my $clause = $self->_GroupClause ) { $QueryString = "SELECT" . $QueryHint . "main.*, COUNT(main.id) OVER() AS search_builder_count_all FROM $QueryString"; $QueryString .= $clause; $QueryString .= $self->_OrderClause; } elsif ( !$self->{'joins_are_distinct'} && $self->_isJoined ) { $self->_DistinctQueryAndCount( \$QueryString ); } else { $QueryString = "SELECT" . $QueryHint . "main.*, COUNT(main.id) OVER() AS search_builder_count_all FROM $QueryString"; $QueryString .= $self->_OrderClause; } $self->_ApplyLimits( \$QueryString ); return ($QueryString); } =head2 Next Returns the next row from the set as an object of the type defined by sub NewItem. When the complete set has been iterated through, returns undef and resets the search such that the following call to Next will start over with the first item retrieved from the database. =cut sub Next { my $self = shift; my @row; return (undef) unless ( $self->_isLimited ); $self->_DoSearch() if $self->{'must_redo_search'}; if ( $self->{'itemscount'} < $self->_RecordCount ) { #return the next item my $item = ( $self->{'items'}[ $self->{'itemscount'} ] ); $self->{'itemscount'}++; return ($item); } else { #we've gone through the whole list. reset the count. $self->GotoFirstItem(); return (undef); } } =head2 GotoFirstItem Starts the recordset counter over from the first item. The next time you call Next, you'll get the first item returned by the database, as if you'd just started iterating through the result set. =cut sub GotoFirstItem { my $self = shift; $self->GotoItem(0); } =head2 GotoItem Takes an integer N and sets the record iterator to N. The first time L is called afterwards, it will return the Nth item found by the search. You should only call GotoItem after you've already fetched at least one result or otherwise forced the search query to run (such as via L). If GotoItem is called before the search query is ever run, it will reset the item iterator and L will return the L item. =cut sub GotoItem { my $self = shift; my $item = shift; $self->{'itemscount'} = $item; } =head2 First Returns the first item =cut sub First { my $self = shift; $self->GotoFirstItem(); return ( $self->Next ); } =head2 Last Returns the last item =cut sub Last { my $self = shift; $self->_DoSearch if $self->{'must_redo_search'}; $self->GotoItem( ( $self->Count ) - 1 ); return ( $self->Next ); } =head2 DistinctFieldValues Returns list with distinct values of field. Limits on collection are accounted, so collection should be Led to get values from the whole table. Takes paramhash with the following keys: =over 4 =item Field Field name. Can be first argument without key. =item Order 'ASC', 'DESC' or undef. Defines whether results should be sorted or not. By default results are not sorted. =item Max Maximum number of elements to fetch. =back =cut sub DistinctFieldValues { my $self = shift; my %args = ( Field => undef, Order => undef, Max => undef, @_%2 ? (Field => @_) : (@_) ); my $query_string = $self->_BuildJoins; $query_string .= ' '. $self->_WhereClause if $self->_isLimited > 0; my $query_hint = $self->QueryHintFormatted; my $column = 'main.'. $args{'Field'}; $query_string = "SELECT" . $query_hint . "DISTINCT $column FROM $query_string"; if ( $args{'Order'} ) { $query_string .= ' ORDER BY '. $column .' '. ($args{'Order'} =~ /^des/i ? 'DESC' : 'ASC'); } my $dbh = $self->_Handle->dbh; my $list = $dbh->selectcol_arrayref( $query_string, { MaxRows => $args{'Max'} } ); return $list? @$list : (); } =head2 ItemsArrayRef Return a reference 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 CombineSearchAndCount 1|0 Tells DBIx::SearchBuilder if it shall search both records and the total count in a single query. =cut my $unsupported_combine_search_and_count_logged; sub CombineSearchAndCount { my $self = shift; if ( @_ ) { if ( $self->_Handle->HasSupportForCombineSearchAndCount ) { $self->{'_combine_search_and_count'} = shift; } else { warn "Current database version " . $self->_Handle->DatabaseVersion . " does not support CombineSearchAndCount. Consider upgrading to a newer version with support for windowing functions." unless $unsupported_combine_search_and_count_logged; $unsupported_combine_search_and_count_logged ||= 1; return undef; } } return $self->{'_combine_search_and_count'}; } =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 statements 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(PreferBind => 0) .')'; $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, let's set # $restriction to point there. Otherwise, let's 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 = @_; my $old_value = $self->_OrderClause; $self->{'order_by'} = \@args; if ( $self->_OrderClause ne $old_value ) { $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'} =~ /^(.*\()(.*\))$/ ) { # 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 = @_; my $old_value = $self->_GroupClause; $self->{'group_by'} = \@args; if ( $self->_GroupClause ne $old_value ) { $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); $table = $self->_Handle->QuoteName($table) if $self->_Handle->QuoteTableNames; 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. When L is set, returns number of records in the page only, otherwise the same as L. =cut sub Count { my $self = shift; # An unlimited search returns no tickets return 0 unless ($self->_isLimited); if ( $self->{'must_redo_search'} ) { if ( $self->RowsPerPage ) { $self->_DoSearch; } else { # No RowsPerPage means Count == CountAll return $self->CountAll; } } return $self->_RecordCount; } =head2 CountAll Returns the total number of potential records in the set, ignoring any L settings. =cut 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 && !defined $self->{'count_all'} ) ) { # If we haven't already asked the database for the row count, do that $self->_DoCount; #Report back the raw # of rows in the database return ( $self->{'count_all'} ); } # if we have paging enabled and have count_all then return it elsif ( $self->RowsPerPage ) { return ( $self->{'count_all'} ); } # If we have loaded everything from the DB we have an # accurate count already. else { return $self->_RecordCount; } } =head2 IsLast Returns true if the current row is the last record in the set. =cut sub IsLast { my $self = shift; return undef unless $self->Count; if ( $self->_ItemsCounter == $self->Count ) { return (1); } else { return (0); } } =head2 Column Call to specify which columns should be loaded from the table. Each calls adds one column to the set. Takes a hash with the following named arguments: =over 4 =item FIELD Column name to fetch or apply function to. =item ALIAS Alias of a table the field is in; defaults to C
=item FUNCTION A SQL function that should be selected instead of FIELD or applied to it. =item AS The B alias to use instead of the default. The default column alias is either the column's name (i.e. what is passed to FIELD) if it is in this table (ALIAS is 'main') or an autogenerated alias. Pass C to skip column aliasing entirely. =back C, C and C are combined according to L. If a FIELD is provided and it is in this table (ALIAS is 'main'), then the column named FIELD and can be accessed as usual by accessors: $articles->Column(FIELD => 'id'); $articles->Column(FIELD => 'Subject', FUNCTION => 'SUBSTR(?, 1, 20)'); my $article = $articles->First; my $aid = $article->id; my $subject_prefix = $article->Subject; Returns the alias used for the column. If FIELD was not provided, or was from another table, then the returned column alias should be passed to the L method to retrieve the column's result: my $time_alias = $articles->Column(FUNCTION => 'NOW()'); my $article = $articles->First; my $now = $article->_Value( $time_alias ); To choose the column's alias yourself, pass a value for the AS parameter (see above). Be careful not to conflict with existing column aliases. =cut sub Column { my $self = shift; my %args = ( TABLE => undef, ALIAS => undef, FIELD => undef, FUNCTION => undef, @_); $args{'ALIAS'} ||= 'main'; my $name = $self->CombineFunctionWithField( %args ) || 'NULL'; my $column = $args{'AS'}; if (not defined $column and not exists $args{'AS'}) { if ( $args{FIELD} && $args{ALIAS} eq 'main' && (!$args{'TABLE'} || $args{'TABLE'} eq $self->Table ) ) { $column = $args{FIELD}; # make sure we don't fetch columns with duplicate aliases if ( $self->{columns} ) { my $suffix = " AS \L$column"; if ( grep index($_, $suffix, -length $suffix) >= 0, @{ $self->{columns} } ) { $column .= scalar @{ $self->{columns} }; } } } else { $column = "col" . @{ $self->{columns} ||= [] }; } } push @{ $self->{columns} ||= [] }, defined($column) ? "$name AS \L$column" : $name; return $column; } =head2 CombineFunctionWithField Takes a hash with three optional arguments: FUNCTION, FIELD and ALIAS. Returns SQL with all three arguments combined according to the following rules. =over 4 =item * FUNCTION or undef returned when FIELD is not provided =item * 'main' ALIAS is used if not provided =item * ALIAS.FIELD returned when FUNCTION is not provided =item * NULL returned if FUNCTION is 'NULL' =item * If FUNCTION contains '?' (question marks) then they are replaced with ALIAS.FIELD and result returned. =item * If FUNCTION has no '(' (opening parenthesis) then ALIAS.FIELD is appended in parentheses and returned. =back Examples: $obj->CombineFunctionWithField() => undef $obj->CombineFunctionWithField(FUNCTION => 'FOO') => 'FOO' $obj->CombineFunctionWithField(FIELD => 'foo') => 'main.foo' $obj->CombineFunctionWithField(ALIAS => 'bar', FIELD => 'foo') => 'bar.foo' $obj->CombineFunctionWithField(FUNCTION => 'FOO(?, ?)', FIELD => 'bar') => 'FOO(main.bar, main.bar)' $obj->CombineFunctionWithField(FUNCTION => 'FOO', ALIAS => 'bar', FIELD => 'baz') => 'FOO(bar.baz)' $obj->CombineFunctionWithField(FUNCTION => 'NULL', FIELD => 'bar') => 'NULL' =cut sub CombineFunctionWithField { my $self = shift; my %args = ( FUNCTION => undef, ALIAS => undef, FIELD => undef, @_ ); unless ( $args{'FIELD'} ) { return $args{'FUNCTION'} || undef; } my $field = ($args{'ALIAS'} || 'main') .'.'. $args{'FIELD'}; return $field unless $args{'FUNCTION'}; my $func = $args{'FUNCTION'}; if ( $func =~ /^DISTINCT\s*COUNT$/i ) { $func = "COUNT(DISTINCT $field)"; } # If we want to substitute elsif ( $func =~ s/\?/$field/g ) { # no need to do anything, we already replaced } # If we want to call a simple function on the column elsif ( $func !~ /\(/ && lc($func) ne 'null' ) { $func = "\U$func\E($field)"; } return $func; } =head2 Columns LIST Specify that we want to load only the columns in LIST =cut sub Columns { my $self = shift; $self->Column( FIELD => $_ ) for @_; } =head2 AdditionalColumn Calls L, but first ensures that this table's standard columns are selected as well. Thus, each call to this method results in an additional column selected instead of replacing the default columns. Takes a hash of parameters which is the same as L. Returns the result of calling L. =cut sub AdditionalColumn { my $self = shift; $self->Column( FUNCTION => "main.*", AS => undef ) unless grep { /^\Qmain.*\E$/ } @{$self->{columns}}; return $self->Column(@_); } =head2 Fields TABLE Return a list of fields in TABLE. These fields are in the case presented by the database, which may be case-sensitive. =cut sub Fields { return (shift)->_Handle->Fields( @_ ); } =head2 HasField { TABLE => undef, FIELD => undef } Returns true if TABLE has field FIELD. Return false otherwise Note: Both TABLE and FIELD are case-sensitive (See: L) =cut sub HasField { my $self = shift; my %args = ( FIELD => undef, TABLE => undef, @_); my $table = $args{TABLE} or die; my $field = $args{FIELD} or die; return grep { $_ eq $field } $self->Fields($table); } =head2 Table [TABLE] If called with an argument, sets this collection's table. Always returns this collection's table. =cut sub Table { my $self = shift; $self->{table} = shift if (@_); return $self->{table}; } =head2 QueryHint [Hint] If called with an argument, sets a query hint for this collection. Call this method before performing additional operations on a collection, such as C, C, etc. Always returns the query hint. When the query hint is included in the SQL query, the C will be included for you. Here's an example query hint for Oracle: $sb->QueryHint("+CURSOR_SHARING_EXACT"); =cut sub QueryHint { my $self = shift; $self->{query_hint} = shift if (@_); return $self->{query_hint}; } =head2 QueryHintFormatted Returns the query hint formatted appropriately for inclusion in SQL queries. =cut sub QueryHintFormatted { my $self = shift; my $QueryHint = $self->QueryHint; # As it turns out, we can't have a space between the opening /* # and the query hint, otherwise Oracle treats this as a comment. return $QueryHint ? " /*$QueryHint */ " : " "; } sub _OptimizeQuery { my $self = shift; my $query = shift; my %args = ( PreferBind => $self->{_prefer_bind} // $PREFER_BIND, @_ ); undef $self->{_bind_values}; if ( $args{PreferBind} ) { ( $$query, my @bind_values ) = $self->_Handle->_ExtractBindValues($$query); # Set _bind_values even if no values are extracted, as we use it in # ApplyLimits to determine if bind is enabled. $self->{_bind_values} = \@bind_values; } } =head1 DEPRECATED METHODS =head2 GroupBy DEPRECATED. Alias for the L method. =cut sub GroupBy { (shift)->GroupByCols( @_ ) } =head2 SetTable DEPRECATED. Alias for the L
method. =cut sub SetTable { my $self = shift; return $self->Table(@_); } =head2 ShowRestrictions DEPRECATED AND DOES NOTHING. =cut sub ShowRestrictions { } =head2 ImportRestrictions DEPRECATED AND DOES NOTHING. =cut sub ImportRestrictions { } # not even documented sub DEBUG { warn "DEBUG is deprecated" } if( eval { require capitalization } ) { capitalization->unimport( __PACKAGE__ ); } 1; __END__ =head1 TESTING In order to test most of the features of C, you need to provide C with a test database. For each DBI driver that you would like to test, set the environment variables C, C, and C to a database name, database username, and database password, where "FOO" is the driver name in all uppercase. You can test as many drivers as you like. (The appropriate C module needs to be installed in order for the test to work.) Note that the C driver will automatically be tested if C is installed, using a temporary file as the database. For example: SB_TEST_MYSQL=test SB_TEST_MYSQL_USER=root SB_TEST_MYSQL_PASS=foo \ SB_TEST_PG=test SB_TEST_PG_USER=postgres make test =head1 AUTHOR Best Practical Solutions, LLC Emodules@bestpractical.comE =head1 CONTRIBUTORS =over =item Ansgar Burchardt =item Audrey Tang =item Ivan Kohler =item Martin King =item Mathieu Arnold =item Matt Knopp =item Matthew Simon Cavalletto =item Nick Morrott =item Oliver Tappe =item Simon Cozens =back =head1 BUGS All bugs should be reported via email to L or via the web at L. =head1 LICENSE AND COPYRIGHT Copyright (C) 2001-2024, Best Practical Solutions LLC. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO DBIx::SearchBuilder::Handle, DBIx::SearchBuilder::Record. =cut DBIx-SearchBuilder-1.81/Makefile.PL0000755000076500000240000000140314451450763016315 0ustar sunnavystaffBEGIN { push @INC, '.' } use inc::Module::Install; name ('DBIx-SearchBuilder'); all_from('lib/DBIx/SearchBuilder.pm'); readme_from('lib/DBIx/SearchBuilder.pm'); perl_version('5.10.1'); 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' => 1.6); 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();